{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Test.Cardano.Ledger.Shelley.Imp.PoolSpec (spec) where

import Cardano.Crypto.Hash.Class (sizeHash)
import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure (..))
import Cardano.Ledger.State (PoolMetadata (..), ppCostL, ppMetadataL, ppVrfL, spsVrf)
import qualified Data.Map.Strict as Map
import Data.Proxy
import Lens.Micro
import Test.Cardano.Ledger.Binary.Arbitrary (genByteString)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest

spec ::
  forall era.
  ( ShelleyEraImp era
  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ShelleyEraImp era,
 InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"POOL" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Register and re-register pools" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"register a pool with too low cost" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- (,) (KeyHash 'StakePool
 -> VRFVerKeyHash 'StakePoolVRF
 -> (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF))
-> ImpM (LedgerSpec era) (KeyHash 'StakePool)
-> ImpM
     (LedgerSpec era)
     (VRFVerKeyHash 'StakePoolVRF
      -> (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM
  (LedgerSpec era)
  (VRFVerKeyHash 'StakePoolVRF
   -> (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF))
-> ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
-> ImpM
     (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      Coin
minPoolCost <- Lens' (PParams era) Coin -> ImpTestM era Coin
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (Coin -> f Coin) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppMinPoolCostL
      Coin
tooLowCost <- Integer -> Coin
Coin (Integer -> Coin)
-> ImpM (LedgerSpec era) Integer -> ImpTestM era Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
0, Coin -> Integer
unCoin Coin
minPoolCost)
      let pps :: ImpM (LedgerSpec era) PoolParams
pps = (\PoolParams
p -> PoolParams
p PoolParams -> (PoolParams -> PoolParams) -> PoolParams
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PoolParams -> Identity PoolParams
Lens' PoolParams Coin
ppCostL ((Coin -> Identity Coin) -> PoolParams -> Identity PoolParams)
-> Coin -> PoolParams -> PoolParams
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
tooLowCost) (PoolParams -> PoolParams)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) PoolParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) PoolParams
pps ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          Tx era
tx
          [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
forall era. Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
StakePoolCostTooLowPOOL (Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era)
-> Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
forall a b. (a -> b) -> a -> b
$ Coin -> Coin -> Mismatch 'RelGTEQ Coin
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch Coin
tooLowCost Coin
minPoolCost]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"register a pool with a reward account having the wrong network id" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ProtVer
pv <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      Credential 'Staking
rewardCredential <- KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Staking -> Credential 'Staking)
-> ImpM (LedgerSpec era) (KeyHash 'Staking)
-> ImpM (LedgerSpec era) (Credential 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      let badRewardAccount :: RewardAccount
badRewardAccount =
            RewardAccount
              { raNetwork :: Network
raNetwork = Network
Mainnet
              , raCredential :: Credential 'Staking
raCredential = Credential 'Staking
rewardCredential
              }
      KeyHash 'StakePool
kh <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      let pps :: ImpM (LedgerSpec era) PoolParams
pps = KeyHash 'StakePool
-> RewardAccount -> ImpM (LedgerSpec era) PoolParams
forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> RewardAccount -> ImpTestM era PoolParams
freshPoolParams KeyHash 'StakePool
kh RewardAccount
badRewardAccount
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) PoolParams
pps ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat). (KnownNat v, 0 <= v, v <= MaxVersion) => Version
natVersion @5
          then
            Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
          else
            Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ 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
Mainnet Network
Testnet) KeyHash 'StakePool
kh]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"register a pool with too big metadata" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ProtVer
pv <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      let maxMetadataSize :: Word
maxMetadataSize = Proxy HASH -> Word
forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
sizeHash (Proxy HASH
forall {k} (t :: k). Proxy t
Proxy :: Proxy HASH)
      Word
tooBigSize <- (Word, Word) -> ImpM (LedgerSpec era) Word
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Word
maxMetadataSize Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1, Word
maxMetadataSize Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
50)
      ByteString
metadataHash <- Gen ByteString -> ImpM (LedgerSpec era) ByteString
forall a. Gen a -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. MonadGen g => Gen a -> g a
liftGen (Gen ByteString -> ImpM (LedgerSpec era) ByteString)
-> Gen ByteString -> ImpM (LedgerSpec era) ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Gen ByteString
genByteString (Int -> Gen ByteString) -> Int -> Gen ByteString
forall a b. (a -> b) -> a -> b
$ Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tooBigSize
      Url
url <- ImpM (LedgerSpec era) Url
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      let metadata :: PoolMetadata
metadata = Url -> ByteString -> PoolMetadata
PoolMetadata Url
url ByteString
metadataHash
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- (,) (KeyHash 'StakePool
 -> VRFVerKeyHash 'StakePoolVRF
 -> (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF))
-> ImpM (LedgerSpec era) (KeyHash 'StakePool)
-> ImpM
     (LedgerSpec era)
     (VRFVerKeyHash 'StakePoolVRF
      -> (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM
  (LedgerSpec era)
  (VRFVerKeyHash 'StakePoolVRF
   -> (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF))
-> ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
-> ImpM
     (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      let pps :: ImpM (LedgerSpec era) PoolParams
pps = (\PoolParams
p -> PoolParams
p PoolParams -> (PoolParams -> PoolParams) -> PoolParams
forall a b. a -> (a -> b) -> b
& (StrictMaybe PoolMetadata -> Identity (StrictMaybe PoolMetadata))
-> PoolParams -> Identity PoolParams
Lens' PoolParams (StrictMaybe PoolMetadata)
ppMetadataL ((StrictMaybe PoolMetadata -> Identity (StrictMaybe PoolMetadata))
 -> PoolParams -> Identity PoolParams)
-> StrictMaybe PoolMetadata -> PoolParams -> PoolParams
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolMetadata -> StrictMaybe PoolMetadata
forall a. a -> StrictMaybe a
SJust PoolMetadata
metadata) (PoolParams -> PoolParams)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) PoolParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) PoolParams
pps ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat). (KnownNat v, 0 <= v, v <= MaxVersion) => Version
natVersion @5
          then
            Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
          else
            Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
PoolMedataHashTooBig KeyHash 'StakePool
kh (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tooBigSize)]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"register a new pool with an already registered VRF" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ProtVer
pv <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      KeyHash 'StakePool
khNew <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat). (KnownNat v, 0 <= v, v <= MaxVersion) => Version
natVersion @11
          then do
            Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
khNew (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
          else do
            Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf]
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
khNew Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. Maybe a
Nothing
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-register a pool with an already registered VRF" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ProtVer
pv <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      (KeyHash 'StakePool
kh1, VRFVerKeyHash 'StakePoolVRF
vrf1) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      (KeyHash 'StakePool
kh2, VRFVerKeyHash 'StakePoolVRF
vrf2) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh1 VRFVerKeyHash 'StakePoolVRF
vrf2 ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat). (KnownNat v, 0 <= v, v <= MaxVersion) => Version
natVersion @11
          then do
            Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh1 (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf1)
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash 'StakePool
kh1 (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf2)
            ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh1 (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf2)
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh2 (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf2)
          else do
            Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
kh1 VRFVerKeyHash 'StakePoolVRF
vrf2]
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh1 (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf1)
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash 'StakePool
kh1 Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. Maybe a
Nothing

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-register a pool with its own VRF" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash 'StakePool
kh Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. Maybe a
Nothing

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-register a pool with a fresh VRF" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      VRFVerKeyHash 'StakePoolVRF
vrfNew <- ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrfNew ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrfNew)
      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrfNew)
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrfNew]
      -- now the original VRF can be reused
      KeyHash 'StakePool
khNew <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrfNew]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"register a new pool with the VRF of a re-registered pool " (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ProtVer
pv <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
_) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      VRFVerKeyHash 'StakePoolVRF
vrfNew <- ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      -- re-register pool with a new vrf
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrfNew ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
      -- try to register a new pool with the new vrf
      KeyHash 'StakePool
khNew <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrfNew ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat). (KnownNat v, 0 <= v, v <= MaxVersion) => Version
natVersion @11
          then do
            Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrfNew)
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
khNew (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrfNew)
          else
            Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrfNew]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"after the epoch changes, reuse VRFs that get overwritten" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      VRFVerKeyHash 'StakePoolVRF
vrf1 <- ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf1 ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf1]
      VRFVerKeyHash 'StakePoolVRF
vrf2 <- ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf2 ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf2]
      VRFVerKeyHash 'StakePoolVRF
vrf3 <- ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf3 ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf3]
      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf3)
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf3]
      -- reuse VRFs that didn't get used
      KeyHash 'StakePool
khNew <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf1 ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
khNew (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf1)
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf1, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf3]
      -- the original pool can be re-registered with one of the discarded VRFs too
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf2 ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf1, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf2, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf3]
      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf1, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf2]
      -- the original pool can be re-registered with the original VRF too
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf1, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf2]
      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf, Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf1]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"before the epoch changes, try to reuse VRFs that get overwritten" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ProtVer
pv <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      VRFVerKeyHash 'StakePoolVRF
vrfNew <- ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrfNew ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      -- try to register a pool with the original VRF that got overwritten
      KeyHash 'StakePool
khNew <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat). (KnownNat v, 0 <= v, v <= MaxVersion) => Version
natVersion @11
          then do
            Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
khNew (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
            ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrfNew)
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
khNew (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
          else do
            Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Retiring pools" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retire an unregistered pool" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      KeyHash 'StakePool
khNew <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
khNew (Word32 -> EpochInterval
EpochInterval Word32
10) ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> ShelleyPoolPredFailure era
StakePoolNotRegisteredOnKeyPOOL KeyHash 'StakePool
khNew]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retire a pool with too high a retirement epoch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
_) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      EpochInterval
maxRetireInterval <- Lens' (PParams era) EpochInterval -> ImpTestM era EpochInterval
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (EpochInterval -> f EpochInterval)
-> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppEMaxL
      EpochNo
curEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
      let maxRetireIntervalPlus :: EpochInterval
maxRetireIntervalPlus =
            Word32 -> EpochInterval
EpochInterval (Word32 -> EpochInterval) -> Word32 -> EpochInterval
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ EpochInterval -> Word32
unEpochInterval EpochInterval
maxRetireInterval Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1
      let supplied :: EpochNo
supplied = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo EpochInterval
maxRetireIntervalPlus

      KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
kh EpochInterval
maxRetireIntervalPlus ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          Tx era
tx
          [ ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
              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
supplied EpochNo
curEpochNo)
                (EpochNo -> EpochNo -> Mismatch 'RelLTEQ EpochNo
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch EpochNo
supplied (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo EpochInterval
maxRetireInterval))
          ]
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
False KeyHash 'StakePool
kh

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retire a pool with too low a retirement epoch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
_) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      EpochNo
curEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
      EpochInterval
maxRetireInterval <- Lens' (PParams era) EpochInterval -> ImpTestM era EpochInterval
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (EpochInterval -> f EpochInterval)
-> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppEMaxL
      KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
kh (Word32 -> EpochInterval
EpochInterval Word32
0) ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          Tx era
tx
          [ ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
              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
curEpochNo EpochNo
curEpochNo)
                (EpochNo -> EpochNo -> Mismatch 'RelLTEQ EpochNo
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch EpochNo
curEpochNo (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo EpochInterval
maxRetireInterval))
          ]
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
False KeyHash 'StakePool
kh

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-register a retiring pool with an already registered vrf" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ProtVer
pv <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      (KeyHash 'StakePool
kh1, VRFVerKeyHash 'StakePoolVRF
_) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      (KeyHash 'StakePool
_, VRFVerKeyHash 'StakePoolVRF
vrf2) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
kh1 (Word32 -> EpochInterval
EpochInterval Word32
10) ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh1 VRFVerKeyHash 'StakePoolVRF
vrf2 ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat). (KnownNat v, 0 <= v, v <= MaxVersion) => Version
natVersion @11
          then do
            Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
            Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
False KeyHash 'StakePool
kh1
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash 'StakePool
kh1 (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf2)
            ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh1 (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf2)
          else do
            Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
kh1 VRFVerKeyHash 'StakePoolVRF
vrf2]
            Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
True KeyHash 'StakePool
kh1
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash 'StakePool
kh1 Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. Maybe a
Nothing

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-register retiring pool with its own VRF" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
kh (Word32 -> EpochInterval
EpochInterval Word32
10) ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
True KeyHash 'StakePool
kh
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
False KeyHash 'StakePool
kh

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-register a retiring pool with a fresh VRF" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
kh (Word32 -> EpochInterval
EpochInterval Word32
10) ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      VRFVerKeyHash 'StakePoolVRF
vrfNew <- ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrfNew ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
False KeyHash 'StakePool
kh
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrfNew)
      ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrfNew)
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrfNew]
      -- now the original VRF can be reused
      KeyHash 'StakePool
khNew <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"register a pool with the VRF of a retiring pool" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ProtVer
pv <- Lens' (PParams era) ProtVer -> ImpTestM era ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      let retirement :: Word32
retirement = Word32
1
      KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
kh (Word32 -> EpochInterval
EpochInterval Word32
retirement) ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      KeyHash 'StakePool
khNew <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat). (KnownNat v, 0 <= v, v <= MaxVersion) => Version
natVersion @11
          then do
            Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
khNew (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
          else do
            Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf]
            KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
khNew Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. Maybe a
Nothing
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
True KeyHash 'StakePool
kh
      Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs (Word32 -> Nat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
retirement)
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
False KeyHash 'StakePool
khNew
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. Maybe a
Nothing

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Retired pools" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-register a pool with the same keyhash and VRF " (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      let retirement :: Word32
retirement = Word32
1
      KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
kh (Word32 -> EpochInterval
EpochInterval Word32
retirement) ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs (Word32 -> Nat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
retirement)
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. Maybe a
Nothing
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"register a pool with the VRF of a retired pool" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool
      let retirement :: Word32
retirement = Word32
1
      KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
kh (Word32 -> EpochInterval
EpochInterval Word32
retirement) ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
True KeyHash 'StakePool
kh
      Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs (Word32 -> Nat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
retirement)
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
False KeyHash 'StakePool
kh
      KeyHash 'StakePool
khNew <- ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
khNew VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
khNew (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
      Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
False KeyHash 'StakePool
khNew
      Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs [Item (Set (VRFVerKeyHash 'StakePoolVRF))
VRFVerKeyHash 'StakePoolVRF
vrf]
  where
    registerNewPool :: ImpM
  (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
registerNewPool = do
      (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf) <- (,) (KeyHash 'StakePool
 -> VRFVerKeyHash 'StakePoolVRF
 -> (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF))
-> ImpM (LedgerSpec era) (KeyHash 'StakePool)
-> ImpM
     (LedgerSpec era)
     (VRFVerKeyHash 'StakePoolVRF
      -> (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM
  (LedgerSpec era)
  (VRFVerKeyHash 'StakePoolVRF
   -> (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF))
-> ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
-> ImpM
     (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      PoolParams -> Tx era
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
PoolParams -> Tx era
registerPoolTx (PoolParams -> Tx era)
-> ImpM (LedgerSpec era) PoolParams
-> ImpM (LedgerSpec era) (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "LEDGER" era)),
 Eq (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx era)
-> (Tx era -> ImpM (LedgerSpec era) ()) -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
      KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
kh (VRFVerKeyHash 'StakePoolVRF -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash 'StakePoolVRF
vrf)
      (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
-> ImpM
     (LedgerSpec era) (KeyHash 'StakePool, VRFVerKeyHash 'StakePoolVRF)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'StakePool
kh, VRFVerKeyHash 'StakePoolVRF
vrf)
    registerPoolTx :: PoolParams -> Tx era
registerPoolTx PoolParams
pps =
      TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
        Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxCert era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [PoolParams -> TxCert era
forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
pps]
    retirePoolTx :: KeyHash 'StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
retirePoolTx KeyHash 'StakePool
kh EpochInterval
retirementInterval = do
      EpochNo
curEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
      let retirement :: EpochNo
retirement = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo EpochInterval
retirementInterval
      Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
        TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
          Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxCert era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [KeyHash 'StakePool -> EpochNo -> TxCert era
forall era.
EraTxCert era =>
KeyHash 'StakePool -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash 'StakePool
kh EpochNo
retirement]
    expectPool :: KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash 'StakePool
poolKh Maybe (VRFVerKeyHash 'StakePoolVRF)
mbVrf = do
      Map (KeyHash 'StakePool) StakePoolState
pps <- PState era -> Map (KeyHash 'StakePool) StakePoolState
forall era. PState era -> Map (KeyHash 'StakePool) StakePoolState
psStakePools (PState era -> Map (KeyHash 'StakePool) StakePoolState)
-> ImpM (LedgerSpec era) (PState era)
-> ImpM (LedgerSpec era) (Map (KeyHash 'StakePool) StakePoolState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (PState era)
getPState
      StakePoolState -> VRFVerKeyHash 'StakePoolVRF
spsVrf (StakePoolState -> VRFVerKeyHash 'StakePoolVRF)
-> Maybe StakePoolState -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
poolKh Map (KeyHash 'StakePool) StakePoolState
pps Maybe (VRFVerKeyHash 'StakePoolVRF)
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Maybe (VRFVerKeyHash 'StakePoolVRF)
mbVrf
    expectFuturePool :: KeyHash 'StakePool
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash 'StakePool
poolKh Maybe (VRFVerKeyHash 'StakePoolVRF)
mbVrf = do
      Map (KeyHash 'StakePool) StakePoolState
fps <- PState era -> Map (KeyHash 'StakePool) StakePoolState
forall era. PState era -> Map (KeyHash 'StakePool) StakePoolState
psFutureStakePools (PState era -> Map (KeyHash 'StakePool) StakePoolState)
-> ImpM (LedgerSpec era) (PState era)
-> ImpM (LedgerSpec era) (Map (KeyHash 'StakePool) StakePoolState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (PState era)
getPState
      StakePoolState -> VRFVerKeyHash 'StakePoolVRF
spsVrf (StakePoolState -> VRFVerKeyHash 'StakePoolVRF)
-> Maybe StakePoolState -> Maybe (VRFVerKeyHash 'StakePoolVRF)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
poolKh Map (KeyHash 'StakePool) StakePoolState
fps Maybe (VRFVerKeyHash 'StakePoolVRF)
-> Maybe (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Maybe (VRFVerKeyHash 'StakePoolVRF)
mbVrf
    expectRetiring :: Bool -> KeyHash 'StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
isRetiring KeyHash 'StakePool
poolKh = do
      Map (KeyHash 'StakePool) EpochNo
retiring <- PState era -> Map (KeyHash 'StakePool) EpochNo
forall era. PState era -> Map (KeyHash 'StakePool) EpochNo
psRetiring (PState era -> Map (KeyHash 'StakePool) EpochNo)
-> ImpM (LedgerSpec era) (PState era)
-> ImpM (LedgerSpec era) (Map (KeyHash 'StakePool) EpochNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (PState era)
getPState
      String -> Bool -> ImpM (LedgerSpec era) ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
String -> Bool -> m ()
assertBool
        (String
"Expected 'retiring' status of: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> String
forall a. Show a => a -> String
show KeyHash 'StakePool
poolKh String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to be: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall a. Show a => a -> String
show Bool
isRetiring)
        (Bool -> ImpM (LedgerSpec era) ())
-> Bool -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> Map (KeyHash 'StakePool) EpochNo -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member KeyHash 'StakePool
poolKh Map (KeyHash 'StakePool) EpochNo
retiring Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
isRetiring
    expectVRFs :: Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs Set (VRFVerKeyHash 'StakePoolVRF)
vrfs = do
      forall (v :: Nat) era.
(EraGov era, KnownNat v, 0 <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast @11 (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        PState era -> Set (VRFVerKeyHash 'StakePoolVRF)
forall era. PState era -> Set (VRFVerKeyHash 'StakePoolVRF)
psVRFKeyHashes (PState era -> Set (VRFVerKeyHash 'StakePoolVRF))
-> ImpM (LedgerSpec era) (PState era)
-> ImpM (LedgerSpec era) (Set (VRFVerKeyHash 'StakePoolVRF))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (PState era)
getPState ImpM (LedgerSpec era) (Set (VRFVerKeyHash 'StakePoolVRF))
-> Set (VRFVerKeyHash 'StakePoolVRF) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Set (VRFVerKeyHash 'StakePoolVRF)
vrfs
    poolParams :: KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) PoolParams
poolParams KeyHash 'StakePool
kh VRFVerKeyHash 'StakePoolVRF
vrf = do
      PoolParams
pps <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount ImpTestM era RewardAccount
-> (RewardAccount -> ImpM (LedgerSpec era) PoolParams)
-> ImpM (LedgerSpec era) PoolParams
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KeyHash 'StakePool
-> RewardAccount -> ImpM (LedgerSpec era) PoolParams
forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> RewardAccount -> ImpTestM era PoolParams
freshPoolParams KeyHash 'StakePool
kh
      PoolParams -> ImpM (LedgerSpec era) PoolParams
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PoolParams -> ImpM (LedgerSpec era) PoolParams)
-> PoolParams -> ImpM (LedgerSpec era) PoolParams
forall a b. (a -> b) -> a -> b
$ PoolParams
pps PoolParams -> (PoolParams -> PoolParams) -> PoolParams
forall a b. a -> (a -> b) -> b
& (VRFVerKeyHash 'StakePoolVRF
 -> Identity (VRFVerKeyHash 'StakePoolVRF))
-> PoolParams -> Identity PoolParams
Lens' PoolParams (VRFVerKeyHash 'StakePoolVRF)
ppVrfL ((VRFVerKeyHash 'StakePoolVRF
  -> Identity (VRFVerKeyHash 'StakePoolVRF))
 -> PoolParams -> Identity PoolParams)
-> VRFVerKeyHash 'StakePoolVRF -> PoolParams -> PoolParams
forall s t a b. ASetter s t a b -> b -> s -> t
.~ VRFVerKeyHash 'StakePoolVRF
vrf
    getPState :: ImpM (LedgerSpec era) (PState era)
getPState = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES @era (SimpleGetter (NewEpochState era) (PState era)
 -> ImpM (LedgerSpec era) (PState era))
-> SimpleGetter (NewEpochState era) (PState era)
-> ImpM (LedgerSpec era) (PState era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PState era -> Const r (PState era))
    -> EpochState era -> Const r (EpochState era))
-> (PState era -> Const r (PState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((PState era -> Const r (PState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (PState era -> Const r (PState era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((PState era -> Const r (PState era))
    -> CertState era -> Const r (CertState era))
-> (PState era -> Const r (PState era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Const r (PState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL