{-# 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
import 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 => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
ShelleyEraImp 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
      (kh, 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
      minPoolCost <- getsPParams ppMinPoolCostL
      tooLowCost <- Coin <$> choose (0, unCoin minPoolCost)
      pps <- poolParams kh vrf
      let tx = StakePoolParams -> Tx TopTx era
forall {era} {l :: TxLevel}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era, Typeable l) =>
StakePoolParams -> Tx l era
registerPoolTx (StakePoolParams
pps StakePoolParams
-> (StakePoolParams -> StakePoolParams) -> StakePoolParams
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> StakePoolParams -> Identity StakePoolParams
Lens' StakePoolParams Coin
sppCostL ((Coin -> Identity Coin)
 -> StakePoolParams -> Identity StakePoolParams)
-> Coin -> StakePoolParams -> StakePoolParams
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
tooLowCost)
      submitFailingTx
        tx
        [injectFailure $ StakePoolCostTooLowPOOL $ Mismatch tooLowCost 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
      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
      rewardCredential <- KeyHashObj <$> freshKeyHash
      let badRewardAccount =
            RewardAccount
              { raNetwork :: Network
raNetwork = Network
Mainnet
              , raCredential :: Credential Staking
raCredential = Credential Staking
rewardCredential
              }
      kh <- freshKeyHash
      pps <- freshPoolParams kh badRewardAccount
      let tx = StakePoolParams -> Tx TopTx era
forall {era} {l :: TxLevel}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era, Typeable l) =>
StakePoolParams -> Tx l era
registerPoolTx StakePoolParams
pps
      if pvMajor pv < natVersion @5
        then
          submitTx_ tx
        else
          submitFailingTx tx [injectFailure $ WrongNetworkPOOL (Mismatch Mainnet Testnet) 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
      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 = Proxy HASH -> Word
forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
sizeHash (Proxy HASH
forall {k} (t :: k). Proxy t
Proxy :: Proxy HASH)
      tooBigSize <- choose (maxMetadataSize + 1, maxMetadataSize + 50)
      metadataHash <- liftGen $ genByteString $ fromIntegral tooBigSize
      url <- arbitrary
      let metadata = Url -> ByteString -> PoolMetadata
PoolMetadata Url
url ByteString
metadataHash
      (kh, vrf) <- (,) <$> freshKeyHash <*> freshKeyHashVRF
      pps <- poolParams kh vrf
      let tx = StakePoolParams -> Tx TopTx era
forall {era} {l :: TxLevel}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era, Typeable l) =>
StakePoolParams -> Tx l era
registerPoolTx (StakePoolParams
pps StakePoolParams
-> (StakePoolParams -> StakePoolParams) -> StakePoolParams
forall a b. a -> (a -> b) -> b
& (StrictMaybe PoolMetadata -> Identity (StrictMaybe PoolMetadata))
-> StakePoolParams -> Identity StakePoolParams
Lens' StakePoolParams (StrictMaybe PoolMetadata)
sppMetadataL ((StrictMaybe PoolMetadata -> Identity (StrictMaybe PoolMetadata))
 -> StakePoolParams -> Identity StakePoolParams)
-> StrictMaybe PoolMetadata -> StakePoolParams -> StakePoolParams
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolMetadata -> StrictMaybe PoolMetadata
forall a. a -> StrictMaybe a
SJust PoolMetadata
metadata)
      if pvMajor pv < natVersion @5
        then
          submitTx_ tx
        else
          submitFailingTx tx [injectFailure $ PoolMedataHashTooBig kh (fromIntegral 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
      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
      (kh, vrf) <- registerNewPool
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrf >>= \Tx TopTx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @11
          then do
            Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ Tx TopTx 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 TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx 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
      expectPool kh (Just 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 and change its delegations in the same 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
      (poolKh, _) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      (poolKh2, _) <- registerNewPool
      stakeCred <- KeyHashObj <$> freshKeyHash
      _ <- registerStakeCredential stakeCred
      stakeCred2 <- KeyHashObj <$> freshKeyHash
      _ <- registerStakeCredential stakeCred2
      delegateStake stakeCred poolKh
      vrf1 <- freshKeyHashVRF
      registerPoolTx <$> poolParams poolKh vrf1 >>= \Tx TopTx era
tx -> do
        Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ Tx TopTx era
tx
        KeyHash StakePool
-> Maybe (Set (Credential Staking)) -> ImpM (LedgerSpec era) ()
expectPoolDelegs KeyHash StakePool
poolKh (Set (Credential Staking) -> Maybe (Set (Credential Staking))
forall a. a -> Maybe a
Just [Item (Set (Credential Staking))
Credential Staking
stakeCred])
        Credential Staking -> KeyHash StakePool -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
Credential Staking -> KeyHash StakePool -> ImpTestM era ()
delegateStake Credential Staking
stakeCred2 KeyHash StakePool
poolKh
        KeyHash StakePool
-> Maybe (Set (Credential Staking)) -> ImpM (LedgerSpec era) ()
expectPoolDelegs KeyHash StakePool
poolKh (Set (Credential Staking) -> Maybe (Set (Credential Staking))
forall a. a -> Maybe a
Just [Item (Set (Credential Staking))
Credential Staking
stakeCred, Item (Set (Credential Staking))
Credential Staking
stakeCred2])
        ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
        KeyHash StakePool
-> Maybe (Set (Credential Staking)) -> ImpM (LedgerSpec era) ()
expectPoolDelegs KeyHash StakePool
poolKh (Set (Credential Staking) -> Maybe (Set (Credential Staking))
forall a. a -> Maybe a
Just [Item (Set (Credential Staking))
Credential Staking
stakeCred, Item (Set (Credential Staking))
Credential Staking
stakeCred2])

      vrf2 <- freshKeyHashVRF
      registerPoolTx <$> poolParams poolKh vrf2 >>= \Tx TopTx era
tx -> do
        Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ Tx TopTx era
tx
        KeyHash StakePool
-> Maybe (Set (Credential Staking)) -> ImpM (LedgerSpec era) ()
expectPoolDelegs KeyHash StakePool
poolKh (Set (Credential Staking) -> Maybe (Set (Credential Staking))
forall a. a -> Maybe a
Just [Item (Set (Credential Staking))
Credential Staking
stakeCred, Item (Set (Credential Staking))
Credential Staking
stakeCred2])

        unRegTxCert <- Credential Staking -> ImpM (LedgerSpec era) (TxCert era)
forall era.
ShelleyEraImp era =>
Credential Staking -> ImpTestM era (TxCert era)
genUnRegTxCert Credential Staking
stakeCred2
        submitTx_ $
          mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ [unRegTxCert]
        expectPoolDelegs poolKh (Just [stakeCred])
        delegateStake stakeCred poolKh2
        expectPoolDelegs poolKh (Just [])
        passEpoch
        expectPoolDelegs poolKh (Just [])

    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
      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
      (kh1, vrf1) <- registerNewPool
      (kh2, vrf2) <- registerNewPool
      registerPoolTx <$> poolParams kh1 vrf2 >>= \Tx TopTx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @11
          then do
            Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ Tx TopTx 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 TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx 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
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      registerPoolTx <$> poolParams kh vrf >>= submitTx_
      expectPool kh (Just vrf)
      expectFuturePool kh (Just vrf)
      passEpoch
      expectPool kh (Just vrf)
      expectFuturePool kh 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
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      vrfNew <- freshKeyHashVRF
      registerPoolTx <$> poolParams kh vrfNew >>= submitTx_
      expectPool kh (Just vrf)
      expectFuturePool kh (Just vrfNew)
      passEpoch
      expectPool kh (Just vrfNew)
      expectVRFs [vrfNew]
      -- now the original VRF can be reused
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrf >>= submitTx_
      expectVRFs [vrf, 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
      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
      (kh, _) <- registerNewPool
      vrfNew <- freshKeyHashVRF
      -- re-register pool with a new vrf
      registerPoolTx <$> poolParams kh vrfNew >>= submitTx_
      passEpoch
      -- try to register a new pool with the new vrf
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrfNew >>= \Tx TopTx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @11
          then do
            Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ Tx TopTx 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 TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx 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
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      vrf1 <- freshKeyHashVRF
      registerPoolTx <$> poolParams kh vrf1 >>= submitTx_
      expectVRFs [vrf, vrf1]
      vrf2 <- freshKeyHashVRF
      registerPoolTx <$> poolParams kh vrf2 >>= submitTx_
      expectVRFs [vrf, vrf2]
      vrf3 <- freshKeyHashVRF
      registerPoolTx <$> poolParams kh vrf3 >>= submitTx_
      expectVRFs [vrf, vrf3]
      passEpoch
      expectPool kh (Just vrf3)
      expectVRFs [vrf3]
      -- reuse VRFs that didn't get used
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrf1 >>= submitTx_
      expectPool khNew (Just vrf1)
      expectVRFs [vrf1, vrf3]
      -- the original pool can be re-registered with one of the discarded VRFs too
      registerPoolTx <$> poolParams kh vrf2 >>= submitTx_
      expectVRFs [vrf1, vrf2, vrf3]
      passEpoch
      expectVRFs [vrf1, vrf2]
      -- the original pool can be re-registered with the original VRF too
      registerPoolTx <$> poolParams kh vrf >>= submitTx_
      expectVRFs [vrf, vrf1, vrf2]
      passEpoch
      expectVRFs [vrf, 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
      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
      (kh, vrf) <- registerNewPool
      vrfNew <- freshKeyHashVRF
      registerPoolTx <$> poolParams kh vrfNew >>= submitTx_
      -- try to register a pool with the original VRF that got overwritten
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrf >>= \Tx TopTx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @11
          then do
            Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ Tx TopTx 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 TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx 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
      khNew <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      retirePoolTx khNew (EpochInterval 10) >>= \Tx TopTx era
tx ->
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx 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
      (kh, _) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      maxRetireInterval <- getsPParams ppEMaxL
      curEpochNo <- getsNES nesELL
      let 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 -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo EpochInterval
maxRetireIntervalPlus

      retirePoolTx kh maxRetireIntervalPlus >>= \Tx TopTx era
tx ->
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          Tx TopTx 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))
          ]
      expectRetiring False 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
      (kh, _) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      curEpochNo <- getsNES nesELL
      maxRetireInterval <- getsPParams ppEMaxL
      retirePoolTx kh (EpochInterval 0) >>= \Tx TopTx era
tx ->
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          Tx TopTx 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))
          ]
      expectRetiring False 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
      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
      (kh1, _) <- registerNewPool
      (_, vrf2) <- registerNewPool
      retirePoolTx kh1 (EpochInterval 10) >>= submitTx_
      registerPoolTx <$> poolParams kh1 vrf2 >>= \Tx TopTx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @11
          then do
            Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ Tx TopTx 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 TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx 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
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      retirePoolTx kh (EpochInterval 10) >>= submitTx_
      expectRetiring True kh
      registerPoolTx <$> poolParams kh vrf >>= submitTx_
      expectPool kh (Just vrf)
      expectRetiring False 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
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      retirePoolTx kh (EpochInterval 10) >>= submitTx_
      vrfNew <- freshKeyHashVRF
      registerPoolTx <$> poolParams kh vrfNew >>= submitTx_
      expectRetiring False kh
      expectFuturePool kh (Just vrfNew)
      passEpoch
      expectPool kh (Just vrfNew)
      expectVRFs [vrfNew]
      -- now the original VRF can be reused
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrf >>= 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
      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
      (kh, vrf) <- registerNewPool
      let retirement = Word32
1
      retirePoolTx kh (EpochInterval retirement) >>= submitTx_
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrf >>= \Tx TopTx era
tx ->
        if ProtVer -> Version
pvMajor ProtVer
pv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @11
          then do
            Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ Tx TopTx 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 TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx 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
      expectRetiring True kh
      passNEpochs (fromIntegral retirement)
      expectRetiring False khNew
      expectPool kh Nothing

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retiring a pool clears its delegations" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (poolKh, _) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      let retirement = Word32
1
      stakeCred1 <- do
        cred <- KeyHashObj <$> freshKeyHash
        _ <- registerStakeCredential cred
        delegateStake cred poolKh
        pure cred

      retirePoolTx poolKh (EpochInterval retirement) >>= submitTx_
      expectPoolDelegs poolKh (Just [stakeCred1])
      stakeCred2 <- do
        cred <- KeyHashObj <$> freshKeyHash
        _ <- registerStakeCredential cred
        delegateStake cred poolKh
        pure cred
      expectPoolDelegs poolKh (Just [stakeCred1, stakeCred2])

      passNEpochs (fromIntegral retirement)
      expectPoolDelegs poolKh 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
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      let retirement = Word32
1
      retirePoolTx kh (EpochInterval retirement) >>= submitTx_
      passNEpochs (fromIntegral retirement)
      expectPool kh Nothing
      registerPoolTx <$> poolParams kh vrf >>= submitTx_
      expectPool kh (Just vrf)
      expectVRFs [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
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      let retirement = Word32
1
      retirePoolTx kh (EpochInterval retirement) >>= submitTx_
      expectRetiring True kh
      passNEpochs (fromIntegral retirement)
      expectRetiring False kh
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrf >>= submitTx_
      expectPool khNew (Just vrf)
      expectRetiring False khNew
      expectVRFs [vrf]
  where
    registerNewPool :: ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool = do
      (kh, 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
      submitTx_ . registerPoolTx =<< poolParams kh vrf
      expectPool kh (Just vrf)
      pure (kh, vrf)
    registerPoolTx :: StakePoolParams -> Tx l era
registerPoolTx StakePoolParams
pps =
      TxBody l era -> Tx l era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody l era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
        Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx l era -> Identity (Tx l era))
-> StrictSeq (TxCert era) -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [StakePoolParams -> TxCert era
forall era. EraTxCert era => StakePoolParams -> TxCert era
RegPoolTxCert StakePoolParams
pps]
    retirePoolTx :: KeyHash StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx l era)
retirePoolTx KeyHash StakePool
kh EpochInterval
retirementInterval = do
      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 -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo EpochInterval
retirementInterval
      pure $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert kh retirement]
    expectPool :: KeyHash StakePool
-> Maybe (VRFVerKeyHash StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash StakePool
poolKh Maybe (VRFVerKeyHash StakePoolVRF)
mbVrf = do
      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
      spsVrf <$> Map.lookup poolKh pps `shouldBe` mbVrf
    expectFuturePool :: KeyHash StakePool
-> Maybe (VRFVerKeyHash StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash StakePool
poolKh Maybe (VRFVerKeyHash StakePoolVRF)
mbVrf = do
      fps <- PState era -> Map (KeyHash StakePool) StakePoolParams
forall era. PState era -> Map (KeyHash StakePool) StakePoolParams
psFutureStakePoolParams (PState era -> Map (KeyHash StakePool) StakePoolParams)
-> ImpM (LedgerSpec era) (PState era)
-> ImpM (LedgerSpec era) (Map (KeyHash StakePool) StakePoolParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (PState era)
getPState
      sppVrf <$> Map.lookup poolKh fps `shouldBe` mbVrf
    expectPoolDelegs :: KeyHash StakePool
-> Maybe (Set (Credential Staking)) -> ImpM (LedgerSpec era) ()
expectPoolDelegs KeyHash StakePool
poolKh Maybe (Set (Credential Staking))
delegs = do
      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
      spsDelegators <$> Map.lookup poolKh pps `shouldBe` delegs
    expectRetiring :: Bool -> KeyHash StakePool -> ImpM (LedgerSpec era) ()
expectRetiring Bool
isRetiring KeyHash StakePool
poolKh = do
      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
      assertBool
        ("Expected 'retiring' status of: " <> show poolKh <> " to be: " <> show isRetiring)
        $ Map.member poolKh retiring == isRetiring
    expectVRFs :: Set (VRFVerKeyHash StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectVRFs Set (VRFVerKeyHash StakePoolVRF)
vrfs = do
      forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= 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
$
        Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Set (VRFVerKeyHash StakePoolVRF)
forall k a. Map k a -> Set k
Map.keysSet (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> Set (VRFVerKeyHash StakePoolVRF))
-> (PState era
    -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> PState era
-> Set (VRFVerKeyHash StakePoolVRF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall era.
PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
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 ->
      ImpTestM era StakePoolParams
    poolParams :: KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ImpTestM era StakePoolParams
poolParams KeyHash StakePool
kh VRFVerKeyHash StakePoolVRF
vrf = do
      pps <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount ImpTestM era RewardAccount
-> (RewardAccount -> ImpTestM era StakePoolParams)
-> ImpTestM era StakePoolParams
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 -> ImpTestM era StakePoolParams
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> RewardAccount -> ImpTestM era StakePoolParams
freshPoolParams KeyHash StakePool
kh
      pure $ pps & sppVrfL .~ 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