{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.Rules.Pool (
  ShelleyPOOL,
  PoolEvent (..),
  PoolEnv (..),
  PredicateFailure,
  ShelleyPoolPredFailure (..),
) where

import Cardano.Crypto.Hash.Class (sizeHash)
import Cardano.Ledger.Address (raNetwork)
import Cardano.Ledger.BaseTypes (
  EpochNo,
  Globals (..),
  Mismatch (..),
  Network,
  Relation (..),
  ShelleyBase,
  addEpochInterval,
  invalidKey,
  knownNonZeroBounded,
  networkId,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  decodeRecordSum,
  encodeListLen,
 )
import Cardano.Ledger.Binary.Coders (Encode (..), encode, (!>))
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.Era (
  ShelleyEra,
  ShelleyPOOL,
  hardforkAlonzoValidatePoolRewardAccountNetID,
  hardforkConwayDisallowDuplicatedVRFKeys,
 )
import qualified Cardano.Ledger.Shelley.SoftForks as SoftForks
import Cardano.Ledger.State
import Control.DeepSeq
import Control.Monad (forM_, when)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition (
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  liftSTS,
  tellEvent,
  (?!),
 )
import qualified Data.ByteString as BS
import Data.Kind (Type)
import qualified Data.Map as Map
import Data.Word (Word8)
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

data PoolEnv era
  = PoolEnv EpochNo (PParams era)
  deriving ((forall x. PoolEnv era -> Rep (PoolEnv era) x)
-> (forall x. Rep (PoolEnv era) x -> PoolEnv era)
-> Generic (PoolEnv era)
forall x. Rep (PoolEnv era) x -> PoolEnv era
forall x. PoolEnv era -> Rep (PoolEnv era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (PoolEnv era) x -> PoolEnv era
forall era x. PoolEnv era -> Rep (PoolEnv era) x
$cfrom :: forall era x. PoolEnv era -> Rep (PoolEnv era) x
from :: forall x. PoolEnv era -> Rep (PoolEnv era) x
$cto :: forall era x. Rep (PoolEnv era) x -> PoolEnv era
to :: forall x. Rep (PoolEnv era) x -> PoolEnv era
Generic)

instance EraPParams era => EncCBOR (PoolEnv era) where
  encCBOR :: PoolEnv era -> Encoding
encCBOR (PoolEnv EpochNo
e PParams era
pp) =
    Encode ('Closed 'Dense) (PoolEnv era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode ('Closed 'Dense) (PoolEnv era) -> Encoding)
-> Encode ('Closed 'Dense) (PoolEnv era) -> Encoding
forall a b. (a -> b) -> a -> b
$
      (EpochNo -> PParams era -> PoolEnv era)
-> Encode ('Closed 'Dense) (EpochNo -> PParams era -> PoolEnv era)
forall t. t -> Encode ('Closed 'Dense) t
Rec EpochNo -> PParams era -> PoolEnv era
forall era. EpochNo -> PParams era -> PoolEnv era
PoolEnv
        Encode ('Closed 'Dense) (EpochNo -> PParams era -> PoolEnv era)
-> Encode ('Closed 'Dense) EpochNo
-> Encode ('Closed 'Dense) (PParams era -> PoolEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> EpochNo -> Encode ('Closed 'Dense) EpochNo
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
e
        Encode ('Closed 'Dense) (PParams era -> PoolEnv era)
-> Encode ('Closed 'Dense) (PParams era)
-> Encode ('Closed 'Dense) (PoolEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> PParams era -> Encode ('Closed 'Dense) (PParams era)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PParams era
pp

deriving instance Show (PParams era) => Show (PoolEnv era)

deriving instance Eq (PParams era) => Eq (PoolEnv era)

instance NFData (PParams era) => NFData (PoolEnv era)

data ShelleyPoolPredFailure era
  = StakePoolNotRegisteredOnKeyPOOL
      -- | KeyHash which cannot be retired since it is not registered
      (KeyHash 'StakePool)
  | StakePoolRetirementWrongEpochPOOL
      (Mismatch 'RelGT EpochNo)
      (Mismatch 'RelLTEQ EpochNo)
  | StakePoolCostTooLowPOOL
      (Mismatch 'RelGTEQ Coin)
  | WrongNetworkPOOL
      (Mismatch 'RelEQ Network)
      -- | Stake Pool ID
      (KeyHash 'StakePool)
  | PoolMedataHashTooBig
      -- | Stake Pool ID
      (KeyHash 'StakePool)
      -- | Size of the metadata hash
      Int
  | VRFKeyHashAlreadyRegistered
      -- | Stake Pool ID
      (KeyHash 'StakePool)
      -- | VRF key attempted to use, that has already been registered
      (VRFVerKeyHash 'StakePoolVRF)
  deriving (ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
(ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool)
-> (ShelleyPoolPredFailure era
    -> ShelleyPoolPredFailure era -> Bool)
-> Eq (ShelleyPoolPredFailure era)
forall era.
ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era.
ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
== :: ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
$c/= :: forall era.
ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
/= :: ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
Eq, Int -> ShelleyPoolPredFailure era -> ShowS
[ShelleyPoolPredFailure era] -> ShowS
ShelleyPoolPredFailure era -> String
(Int -> ShelleyPoolPredFailure era -> ShowS)
-> (ShelleyPoolPredFailure era -> String)
-> ([ShelleyPoolPredFailure era] -> ShowS)
-> Show (ShelleyPoolPredFailure era)
forall era. Int -> ShelleyPoolPredFailure era -> ShowS
forall era. [ShelleyPoolPredFailure era] -> ShowS
forall era. ShelleyPoolPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> ShelleyPoolPredFailure era -> ShowS
showsPrec :: Int -> ShelleyPoolPredFailure era -> ShowS
$cshow :: forall era. ShelleyPoolPredFailure era -> String
show :: ShelleyPoolPredFailure era -> String
$cshowList :: forall era. [ShelleyPoolPredFailure era] -> ShowS
showList :: [ShelleyPoolPredFailure era] -> ShowS
Show, (forall x.
 ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x)
-> (forall x.
    Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era)
-> Generic (ShelleyPoolPredFailure era)
forall x.
Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era
forall x.
ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era
forall era x.
ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x
$cfrom :: forall era x.
ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x
from :: forall x.
ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x
$cto :: forall era x.
Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era
to :: forall x.
Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era
Generic)

type instance EraRuleFailure "POOL" ShelleyEra = ShelleyPoolPredFailure ShelleyEra

instance InjectRuleFailure "POOL" ShelleyPoolPredFailure ShelleyEra

instance NoThunks (ShelleyPoolPredFailure era)

instance NFData (ShelleyPoolPredFailure era)

instance EraPParams era => STS (ShelleyPOOL era) where
  type State (ShelleyPOOL era) = PState era

  type Signal (ShelleyPOOL era) = PoolCert

  type Environment (ShelleyPOOL era) = PoolEnv era

  type BaseM (ShelleyPOOL era) = ShelleyBase
  type PredicateFailure (ShelleyPOOL era) = ShelleyPoolPredFailure era
  type Event (ShelleyPOOL era) = PoolEvent era

  transitionRules :: [TransitionRule (ShelleyPOOL era)]
transitionRules = [TransitionRule (ShelleyPOOL era)
forall (ledger :: * -> *) era.
(EraPParams era, Signal (ledger era) ~ PoolCert,
 Environment (ledger era) ~ PoolEnv era,
 State (ledger era) ~ PState era, STS (ledger era),
 Event (ledger era) ~ PoolEvent era,
 BaseM (ledger era) ~ ShelleyBase,
 PredicateFailure (ledger era) ~ ShelleyPoolPredFailure era) =>
TransitionRule (ledger era)
poolDelegationTransition]

data PoolEvent era
  = RegisterPool (KeyHash 'StakePool)
  | ReregisterPool (KeyHash 'StakePool)
  deriving ((forall x. PoolEvent era -> Rep (PoolEvent era) x)
-> (forall x. Rep (PoolEvent era) x -> PoolEvent era)
-> Generic (PoolEvent era)
forall x. Rep (PoolEvent era) x -> PoolEvent era
forall x. PoolEvent era -> Rep (PoolEvent era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (PoolEvent era) x -> PoolEvent era
forall era x. PoolEvent era -> Rep (PoolEvent era) x
$cfrom :: forall era x. PoolEvent era -> Rep (PoolEvent era) x
from :: forall x. PoolEvent era -> Rep (PoolEvent era) x
$cto :: forall era x. Rep (PoolEvent era) x -> PoolEvent era
to :: forall x. Rep (PoolEvent era) x -> PoolEvent era
Generic, PoolEvent era -> PoolEvent era -> Bool
(PoolEvent era -> PoolEvent era -> Bool)
-> (PoolEvent era -> PoolEvent era -> Bool) -> Eq (PoolEvent era)
forall era. PoolEvent era -> PoolEvent era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era. PoolEvent era -> PoolEvent era -> Bool
== :: PoolEvent era -> PoolEvent era -> Bool
$c/= :: forall era. PoolEvent era -> PoolEvent era -> Bool
/= :: PoolEvent era -> PoolEvent era -> Bool
Eq)

instance NFData (PoolEvent era)

instance Era era => EncCBOR (ShelleyPoolPredFailure era) where
  encCBOR :: ShelleyPoolPredFailure era -> Encoding
encCBOR = \case
    StakePoolNotRegisteredOnKeyPOOL KeyHash 'StakePool
kh ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
0 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
kh
    StakePoolRetirementWrongEpochPOOL (Mismatch EpochNo
_ EpochNo
gtExpected) (Mismatch EpochNo
ltSupplied EpochNo
ltExpected) ->
      Word -> Encoding
encodeListLen Word
4
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
1 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR EpochNo
gtExpected
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR EpochNo
ltSupplied
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR EpochNo
ltExpected
    StakePoolCostTooLowPOOL (Mismatch Coin
supplied Coin
expected) ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
3 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
supplied Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
expected
    WrongNetworkPOOL (Mismatch Network
supplied Network
expected) KeyHash 'StakePool
c ->
      Word -> Encoding
encodeListLen Word
4 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
4 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Network -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Network
expected Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Network -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Network
supplied Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
c
    PoolMedataHashTooBig KeyHash 'StakePool
a Int
b ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
5 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Int -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Int
b
    VRFKeyHashAlreadyRegistered KeyHash 'StakePool
a VRFVerKeyHash 'StakePoolVRF
b ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
6 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VRFVerKeyHash 'StakePoolVRF -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VRFVerKeyHash 'StakePoolVRF
b

-- `ShelleyPoolPredFailure` is used in Conway POOL rule, so we need to keep the serialization unchanged
instance Era era => DecCBOR (ShelleyPoolPredFailure era) where
  decCBOR :: forall s. Decoder s (ShelleyPoolPredFailure era)
decCBOR = Text
-> (Word -> Decoder s (Int, ShelleyPoolPredFailure era))
-> Decoder s (ShelleyPoolPredFailure era)
forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
"PredicateFailure (POOL era)" ((Word -> Decoder s (Int, ShelleyPoolPredFailure era))
 -> Decoder s (ShelleyPoolPredFailure era))
-> (Word -> Decoder s (Int, ShelleyPoolPredFailure era))
-> Decoder s (ShelleyPoolPredFailure era)
forall a b. (a -> b) -> a -> b
$
    \case
      Word
0 -> do
        KeyHash 'StakePool
kh <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, KeyHash 'StakePool -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> ShelleyPoolPredFailure era
StakePoolNotRegisteredOnKeyPOOL KeyHash 'StakePool
kh)
      Word
1 -> do
        EpochNo
gtExpected <- Decoder s EpochNo
forall s. Decoder s EpochNo
forall a s. DecCBOR a => Decoder s a
decCBOR
        EpochNo
ltSupplied <- Decoder s EpochNo
forall s. Decoder s EpochNo
forall a s. DecCBOR a => Decoder s a
decCBOR
        EpochNo
ltExpected <- Decoder s EpochNo
forall s. Decoder s EpochNo
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( Int
4
          , Mismatch 'RelGT EpochNo
-> Mismatch 'RelLTEQ EpochNo -> ShelleyPoolPredFailure era
forall era.
Mismatch 'RelGT EpochNo
-> Mismatch 'RelLTEQ EpochNo -> ShelleyPoolPredFailure era
StakePoolRetirementWrongEpochPOOL
              (EpochNo -> EpochNo -> Mismatch 'RelGT EpochNo
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch EpochNo
ltSupplied EpochNo
gtExpected)
              (EpochNo -> EpochNo -> Mismatch 'RelLTEQ EpochNo
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch EpochNo
ltSupplied EpochNo
ltExpected)
          )
      Word
2 -> String -> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"WrongCertificateTypePOOL has been removed as impossible case"
      Word
3 -> do
        Coin
supplied <- Decoder s Coin
forall s. Decoder s Coin
forall a s. DecCBOR a => Decoder s a
decCBOR
        Coin
expected <- Decoder s Coin
forall s. Decoder s Coin
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
forall era. Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
StakePoolCostTooLowPOOL (Coin -> Coin -> Mismatch 'RelGTEQ Coin
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch Coin
supplied Coin
expected))
      Word
4 -> do
        Network
expectedNetId <- Decoder s Network
forall s. Decoder s Network
forall a s. DecCBOR a => Decoder s a
decCBOR
        Network
suppliedNetId <- Decoder s Network
forall s. Decoder s Network
forall a s. DecCBOR a => Decoder s a
decCBOR
        KeyHash 'StakePool
poolId <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
4, Mismatch 'RelEQ Network
-> KeyHash 'StakePool -> ShelleyPoolPredFailure era
forall era.
Mismatch 'RelEQ Network
-> KeyHash 'StakePool -> ShelleyPoolPredFailure era
WrongNetworkPOOL (Network -> Network -> Mismatch 'RelEQ Network
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch Network
suppliedNetId Network
expectedNetId) KeyHash 'StakePool
poolId)
      Word
5 -> do
        KeyHash 'StakePool
poolID <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
        Int
s <- Decoder s Int
forall s. Decoder s Int
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
PoolMedataHashTooBig KeyHash 'StakePool
poolID Int
s)
      Word
6 -> do
        KeyHash 'StakePool
poolID <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
        VRFVerKeyHash 'StakePoolVRF
vrfKeyHash <- Decoder s (VRFVerKeyHash 'StakePoolVRF)
forall s. Decoder s (VRFVerKeyHash 'StakePoolVRF)
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
poolID VRFVerKeyHash 'StakePoolVRF
vrfKeyHash)
      Word
k -> Word -> Decoder s (Int, ShelleyPoolPredFailure era)
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
k

poolDelegationTransition ::
  forall (ledger :: Type -> Type) era.
  ( EraPParams era
  , Signal (ledger era) ~ PoolCert
  , Environment (ledger era) ~ PoolEnv era
  , State (ledger era) ~ PState era
  , STS (ledger era)
  , Event (ledger era) ~ PoolEvent era
  , BaseM (ledger era) ~ ShelleyBase
  , PredicateFailure (ledger era) ~ ShelleyPoolPredFailure era
  ) =>
  TransitionRule (ledger era)
poolDelegationTransition :: forall (ledger :: * -> *) era.
(EraPParams era, Signal (ledger era) ~ PoolCert,
 Environment (ledger era) ~ PoolEnv era,
 State (ledger era) ~ PState era, STS (ledger era),
 Event (ledger era) ~ PoolEvent era,
 BaseM (ledger era) ~ ShelleyBase,
 PredicateFailure (ledger era) ~ ShelleyPoolPredFailure era) =>
TransitionRule (ledger era)
poolDelegationTransition = do
  TRC
    ( PoolEnv EpochNo
cEpoch PParams era
pp
      , ps :: State (ledger era)
ps@PState {Map (KeyHash 'StakePool) StakePoolState
psStakePools :: Map (KeyHash 'StakePool) StakePoolState
psStakePools :: forall era. PState era -> Map (KeyHash 'StakePool) StakePoolState
psStakePools, Map (KeyHash 'StakePool) StakePoolState
psFutureStakePools :: Map (KeyHash 'StakePool) StakePoolState
psFutureStakePools :: forall era. PState era -> Map (KeyHash 'StakePool) StakePoolState
psFutureStakePools, Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
psVRFKeyHashes :: Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
psVRFKeyHashes :: forall era.
PState era -> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
psVRFKeyHashes}
      , Signal (ledger era)
poolCert
      ) <-
    Rule
  (ledger era) 'Transition (RuleContext 'Transition (ledger era))
F (Clause (ledger era) 'Transition) (TRC (ledger era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  case Signal (ledger era)
poolCert of
    RegPool poolParams :: PoolParams
poolParams@PoolParams {KeyHash 'StakePool
ppId :: KeyHash 'StakePool
ppId :: PoolParams -> KeyHash 'StakePool
ppId, VRFVerKeyHash 'StakePoolVRF
ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppVrf :: PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppVrf, RewardAccount
ppRewardAccount :: RewardAccount
ppRewardAccount :: PoolParams -> RewardAccount
ppRewardAccount, StrictMaybe PoolMetadata
ppMetadata :: StrictMaybe PoolMetadata
ppMetadata :: PoolParams -> StrictMaybe PoolMetadata
ppMetadata, Coin
ppCost :: Coin
ppCost :: PoolParams -> Coin
ppCost} -> do
      let pv :: ProtVer
pv = PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      Bool
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
hardforkAlonzoValidatePoolRewardAccountNetID ProtVer
pv) (F (Clause (ledger era) 'Transition) ()
 -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ do
        Network
actualNetID <- BaseM (ledger era) Network -> Rule (ledger era) 'Transition Network
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (ledger era) Network
 -> Rule (ledger era) 'Transition Network)
-> BaseM (ledger era) Network
-> Rule (ledger era) 'Transition Network
forall a b. (a -> b) -> a -> b
$ (Globals -> Network) -> ReaderT Globals Identity Network
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Network
networkId
        let suppliedNetID :: Network
suppliedNetID = RewardAccount -> Network
raNetwork RewardAccount
ppRewardAccount
        Network
actualNetID
          Network -> Network -> Bool
forall a. Eq a => a -> a -> Bool
== Network
suppliedNetID
            Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Mismatch 'RelEQ Network
-> KeyHash 'StakePool -> ShelleyPoolPredFailure era
forall era.
Mismatch 'RelEQ Network
-> KeyHash 'StakePool -> ShelleyPoolPredFailure era
WrongNetworkPOOL
              Mismatch
                { mismatchSupplied :: Network
mismatchSupplied = Network
suppliedNetID
                , mismatchExpected :: Network
mismatchExpected = Network
actualNetID
                }
              KeyHash 'StakePool
ppId

      Bool
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
SoftForks.restrictPoolMetadataHash ProtVer
pv) (F (Clause (ledger era) 'Transition) ()
 -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        StrictMaybe PoolMetadata
-> (PoolMetadata -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ StrictMaybe PoolMetadata
ppMetadata ((PoolMetadata -> F (Clause (ledger era) 'Transition) ())
 -> F (Clause (ledger era) 'Transition) ())
-> (PoolMetadata -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ \PoolMetadata
pmd ->
          let s :: Int
s = ByteString -> Int
BS.length (PoolMetadata -> ByteString
pmHash PoolMetadata
pmd)
           in Int
s
                Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([HASH] -> Word
forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
sizeHash ([] @HASH))
                  Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
PoolMedataHashTooBig KeyHash 'StakePool
ppId Int
s

      let minPoolCost :: Coin
minPoolCost = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppMinPoolCostL
      Coin
ppCost
        Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
minPoolCost
          Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
forall era. Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
StakePoolCostTooLowPOOL
            Mismatch
              { mismatchSupplied :: Coin
mismatchSupplied = Coin
ppCost
              , mismatchExpected :: Coin
mismatchExpected = Coin
minPoolCost
              }
      case KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
ppId Map (KeyHash 'StakePool) StakePoolState
psStakePools of
        -- register new, Pool-Reg
        Maybe StakePoolState
Nothing -> do
          Bool
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
hardforkConwayDisallowDuplicatedVRFKeys ProtVer
pv) (F (Clause (ledger era) 'Transition) ()
 -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ do
            VRFVerKeyHash 'StakePoolVRF
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember VRFVerKeyHash 'StakePoolVRF
ppVrf Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
psVRFKeyHashes Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
ppId VRFVerKeyHash 'StakePoolVRF
ppVrf
          let updateVRFKeyHash :: Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
updateVRFKeyHash
                | ProtVer -> Bool
hardforkConwayDisallowDuplicatedVRFKeys ProtVer
pv = VRFVerKeyHash 'StakePoolVRF
-> NonZero Word64
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert VRFVerKeyHash 'StakePoolVRF
ppVrf (forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @1)
                | Bool
otherwise = Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
forall a. a -> a
id
          Event (ledger era) -> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ledger era) -> F (Clause (ledger era) 'Transition) ())
-> Event (ledger era) -> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> PoolEvent era
forall era. KeyHash 'StakePool -> PoolEvent era
RegisterPool KeyHash 'StakePool
ppId
          PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a. a -> F (Clause (ledger era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era -> F (Clause (ledger era) 'Transition) (PState era))
-> PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a b. (a -> b) -> a -> b
$
            PState era
State (ledger era)
ps
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (KeyHash 'StakePool) StakePoolState
 -> Identity (Map (KeyHash 'StakePool) StakePoolState))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash 'StakePool) StakePoolState
 -> f (Map (KeyHash 'StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL ((Map (KeyHash 'StakePool) StakePoolState
  -> Identity (Map (KeyHash 'StakePool) StakePoolState))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash 'StakePool) StakePoolState
    -> Map (KeyHash 'StakePool) StakePoolState)
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyHash 'StakePool
-> StakePoolState
-> Map (KeyHash 'StakePool) StakePoolState
-> Map (KeyHash 'StakePool) StakePoolState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
ppId (CompactForm Coin -> PoolParams -> StakePoolState
mkStakePoolState (PParams era
pp PParams era
-> Getting (CompactForm Coin) (PParams era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (PParams era) (CompactForm Coin)
forall era.
EraPParams era =>
Lens' (PParams era) (CompactForm Coin)
Lens' (PParams era) (CompactForm Coin)
ppPoolDepositCompactL) PoolParams
poolParams)
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
 -> Identity (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
 -> f (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)))
-> PState era -> f (PState era)
psVRFKeyHashesL ((Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
  -> Identity (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)))
 -> PState era -> Identity (PState era))
-> (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
    -> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64))
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
updateVRFKeyHash
        -- re-register Pool
        Just StakePoolState
stakePoolState -> do
          Bool
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
hardforkConwayDisallowDuplicatedVRFKeys ProtVer
pv) (F (Clause (ledger era) 'Transition) ()
 -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ do
            VRFVerKeyHash 'StakePoolVRF
ppVrf VRFVerKeyHash 'StakePoolVRF -> VRFVerKeyHash 'StakePoolVRF -> Bool
forall a. Eq a => a -> a -> Bool
== StakePoolState
stakePoolState StakePoolState
-> Getting
     (VRFVerKeyHash 'StakePoolVRF)
     StakePoolState
     (VRFVerKeyHash 'StakePoolVRF)
-> VRFVerKeyHash 'StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash 'StakePoolVRF)
  StakePoolState
  (VRFVerKeyHash 'StakePoolVRF)
Lens' StakePoolState (VRFVerKeyHash 'StakePoolVRF)
spsVrfL
              Bool -> Bool -> Bool
|| VRFVerKeyHash 'StakePoolVRF
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember VRFVerKeyHash 'StakePoolVRF
ppVrf Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
psVRFKeyHashes Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
ppId VRFVerKeyHash 'StakePoolVRF
ppVrf
          let updateFutureVRFKeyHash :: Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
updateFutureVRFKeyHash
                | ProtVer -> Bool
hardforkConwayDisallowDuplicatedVRFKeys ProtVer
pv =
                    -- If a pool re-registers with a fresh VRF, we have to record it in the map,
                    -- but also remove the previous VRFHashKey potentially stored in previous re-registration within the same epoch,
                    -- which we retrieve from futureStakePools.
                    case KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
ppId Map (KeyHash 'StakePool) StakePoolState
psFutureStakePools of
                      Maybe StakePoolState
Nothing -> VRFVerKeyHash 'StakePoolVRF
-> NonZero Word64
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert VRFVerKeyHash 'StakePoolVRF
ppVrf (forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @1)
                      Just StakePoolState
futureStakePoolState
                        | StakePoolState
futureStakePoolState StakePoolState
-> Getting
     (VRFVerKeyHash 'StakePoolVRF)
     StakePoolState
     (VRFVerKeyHash 'StakePoolVRF)
-> VRFVerKeyHash 'StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash 'StakePoolVRF)
  StakePoolState
  (VRFVerKeyHash 'StakePoolVRF)
Lens' StakePoolState (VRFVerKeyHash 'StakePoolVRF)
spsVrfL VRFVerKeyHash 'StakePoolVRF -> VRFVerKeyHash 'StakePoolVRF -> Bool
forall a. Eq a => a -> a -> Bool
/= VRFVerKeyHash 'StakePoolVRF
ppVrf ->
                            (VRFVerKeyHash 'StakePoolVRF
-> NonZero Word64
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert VRFVerKeyHash 'StakePoolVRF
ppVrf (forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @1))
                              (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
 -> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64))
-> (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
    -> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64))
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VRFVerKeyHash 'StakePoolVRF
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (StakePoolState
futureStakePoolState StakePoolState
-> Getting
     (VRFVerKeyHash 'StakePoolVRF)
     StakePoolState
     (VRFVerKeyHash 'StakePoolVRF)
-> VRFVerKeyHash 'StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash 'StakePoolVRF)
  StakePoolState
  (VRFVerKeyHash 'StakePoolVRF)
Lens' StakePoolState (VRFVerKeyHash 'StakePoolVRF)
spsVrfL)
                        | Bool
otherwise -> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
forall a. a -> a
id
                | Bool
otherwise = Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
forall a. a -> a
id
          Event (ledger era) -> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ledger era) -> F (Clause (ledger era) 'Transition) ())
-> Event (ledger era) -> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> PoolEvent era
forall era. KeyHash 'StakePool -> PoolEvent era
ReregisterPool KeyHash 'StakePool
ppId
          -- NOTE: The `ppId` is already registered, so we want to reregister
          -- it. That means adding it to the Future Stake Pools (if it is not
          -- there already), and overriding its range with the new 'poolParams',
          -- if it is.
          --
          -- We must also unretire it, if it has been scheduled for retirement.
          --
          -- The deposit does not change. One pays the deposit just once. Only
          -- if it is fully retired (i.e. it's deposit has been refunded, and it
          -- has been removed from the registered pools).  does it need to pay a
          -- new deposit (at the current deposit amount). But of course, if that
          -- has happened, we cannot be in this branch of the case statement.
          PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a. a -> F (Clause (ledger era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era -> F (Clause (ledger era) 'Transition) (PState era))
-> PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a b. (a -> b) -> a -> b
$
            PState era
State (ledger era)
ps
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (KeyHash 'StakePool) StakePoolState
 -> Identity (Map (KeyHash 'StakePool) StakePoolState))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash 'StakePool) StakePoolState
 -> f (Map (KeyHash 'StakePool) StakePoolState))
-> PState era -> f (PState era)
psFutureStakePoolsL ((Map (KeyHash 'StakePool) StakePoolState
  -> Identity (Map (KeyHash 'StakePool) StakePoolState))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash 'StakePool) StakePoolState
    -> Map (KeyHash 'StakePool) StakePoolState)
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyHash 'StakePool
-> StakePoolState
-> Map (KeyHash 'StakePool) StakePoolState
-> Map (KeyHash 'StakePool) StakePoolState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
ppId (CompactForm Coin -> PoolParams -> StakePoolState
mkStakePoolState (StakePoolState
stakePoolState StakePoolState
-> Getting (CompactForm Coin) StakePoolState (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) StakePoolState (CompactForm Coin)
Lens' StakePoolState (CompactForm Coin)
spsDepositL) PoolParams
poolParams)
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (KeyHash 'StakePool) EpochNo
 -> Identity (Map (KeyHash 'StakePool) EpochNo))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash 'StakePool) EpochNo
 -> f (Map (KeyHash 'StakePool) EpochNo))
-> PState era -> f (PState era)
psRetiringL ((Map (KeyHash 'StakePool) EpochNo
  -> Identity (Map (KeyHash 'StakePool) EpochNo))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash 'StakePool) EpochNo
    -> Map (KeyHash 'StakePool) EpochNo)
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyHash 'StakePool
-> Map (KeyHash 'StakePool) EpochNo
-> Map (KeyHash 'StakePool) EpochNo
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete KeyHash 'StakePool
ppId
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
 -> Identity (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
 -> f (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)))
-> PState era -> f (PState era)
psVRFKeyHashesL ((Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
  -> Identity (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)))
 -> PState era -> Identity (PState era))
-> (Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
    -> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64))
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash 'StakePoolVRF) (NonZero Word64)
updateFutureVRFKeyHash
    RetirePool KeyHash 'StakePool
ppId EpochNo
e -> do
      KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member KeyHash 'StakePool
ppId Map (KeyHash 'StakePool) StakePoolState
psStakePools Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! KeyHash 'StakePool -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> ShelleyPoolPredFailure era
StakePoolNotRegisteredOnKeyPOOL KeyHash 'StakePool
ppId
      let maxEpoch :: EpochInterval
maxEpoch = PParams era
pp PParams era
-> Getting EpochInterval (PParams era) EpochInterval
-> EpochInterval
forall s a. s -> Getting a s a -> a
^. Getting EpochInterval (PParams era) EpochInterval
forall era. EraPParams era => Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppEMaxL
          limitEpoch :: EpochNo
limitEpoch = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
cEpoch EpochInterval
maxEpoch
      (EpochNo
cEpoch EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
< EpochNo
e Bool -> Bool -> Bool
&& EpochNo
e EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
<= EpochNo
limitEpoch)
        Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Mismatch 'RelGT EpochNo
-> Mismatch 'RelLTEQ EpochNo -> ShelleyPoolPredFailure era
forall era.
Mismatch 'RelGT EpochNo
-> Mismatch 'RelLTEQ EpochNo -> ShelleyPoolPredFailure era
StakePoolRetirementWrongEpochPOOL
          Mismatch -- 'RelGT - The supplied value should be greater than the current epoch
            { mismatchSupplied :: EpochNo
mismatchSupplied = EpochNo
e
            , mismatchExpected :: EpochNo
mismatchExpected = EpochNo
cEpoch
            }
          Mismatch -- 'RelLTEQ - The supplied value should be less then or equal to ppEMax after the current epoch
            { mismatchSupplied :: EpochNo
mismatchSupplied = EpochNo
e
            , mismatchExpected :: EpochNo
mismatchExpected = EpochNo
limitEpoch
            }
      -- We just schedule it for retirement. When it is retired we refund the deposit (see POOLREAP)
      PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a. a -> F (Clause (ledger era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era -> F (Clause (ledger era) 'Transition) (PState era))
-> PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a b. (a -> b) -> a -> b
$ PState era
State (ledger era)
ps PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (KeyHash 'StakePool) EpochNo
 -> Identity (Map (KeyHash 'StakePool) EpochNo))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash 'StakePool) EpochNo
 -> f (Map (KeyHash 'StakePool) EpochNo))
-> PState era -> f (PState era)
psRetiringL ((Map (KeyHash 'StakePool) EpochNo
  -> Identity (Map (KeyHash 'StakePool) EpochNo))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash 'StakePool) EpochNo
    -> Map (KeyHash 'StakePool) EpochNo)
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyHash 'StakePool
-> EpochNo
-> Map (KeyHash 'StakePool) EpochNo
-> Map (KeyHash 'StakePool) EpochNo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
ppId EpochNo
e