{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.Conway.Imp.HardForkSpec (spec) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Shelley.LedgerState
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Rational
import Test.Cardano.Ledger.Imp.Common

spec ::
  forall era.
  ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = do
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"VRF Keyhashes get populated at v11 HardFork" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Since we're testing the HardFork to 11, the test only makes sense for protocol version 10
    forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersion @10 (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      (KeyHash 'StakePool
kh1, VRFVerKeyHash 'StakePoolVRF
vrf1) <- (,) (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
      KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpTestM era ()
forall {era}.
(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 ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) ()
registerStakePool KeyHash 'StakePool
kh1 VRFVerKeyHash 'StakePoolVRF
vrf1
      (KeyHash 'StakePool
kh2, VRFVerKeyHash 'StakePoolVRF
vrf2) <- (,) (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
      KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpTestM era ()
forall {era}.
(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 ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) ()
registerStakePool KeyHash 'StakePool
kh2 VRFVerKeyHash 'StakePoolVRF
vrf2
      VRFVerKeyHash 'StakePoolVRF
vrf3 <- ImpM (LedgerSpec era) (VRFVerKeyHash 'StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      -- re-register with a new key, so vrf1 should not be present after the hard fork
      KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpTestM era ()
forall {era}.
(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 ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) ()
registerStakePool KeyHash 'StakePool
kh1 VRFVerKeyHash 'StakePoolVRF
vrf3
      -- register a new pool with an existing vrf
      KeyHash 'StakePool
kh3 <- 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
-> VRFVerKeyHash 'StakePoolVRF -> ImpTestM era ()
forall {era}.
(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 ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) ()
registerStakePool KeyHash 'StakePool
kh3 VRFVerKeyHash 'StakePoolVRF
vrf2
      -- register and retire a pool before the hard fork, so vrf4 should not be present after the hard fork
      (KeyHash 'StakePool
kh4, VRFVerKeyHash 'StakePoolVRF
vrf4) <- (,) (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
      KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpTestM era ()
forall {era}.
(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 ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) ()
registerStakePool KeyHash 'StakePool
kh4 VRFVerKeyHash 'StakePoolVRF
vrf4
      KeyHash 'StakePool -> EpochInterval -> ImpTestM era ()
forall {era}.
(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 ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
KeyHash 'StakePool -> EpochInterval -> ImpM (LedgerSpec era) ()
retireStakePool KeyHash 'StakePool
kh4 (Word32 -> EpochInterval
EpochInterval Word32
1)
      -- register and schedule retirement for after the hard fork, so vrf5 should be present after the hard fork
      (KeyHash 'StakePool
kh5, VRFVerKeyHash 'StakePoolVRF
vrf5) <- (,) (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
      KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpTestM era ()
forall {era}.
(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 ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) ()
registerStakePool KeyHash 'StakePool
kh5 VRFVerKeyHash 'StakePoolVRF
vrf5
      KeyHash 'StakePool -> EpochInterval -> ImpTestM era ()
forall {era}.
(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 ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
KeyHash 'StakePool -> EpochInterval -> ImpM (LedgerSpec era) ()
retireStakePool KeyHash 'StakePool
kh5 (Word32 -> EpochInterval
EpochInterval Word32
5)

      [VRFVerKeyHash 'StakePoolVRF] -> ImpTestM era ()
expectVRFs [] -- VRF keyhashes in PState is not yet populated
      ImpTestM era ()
enactHardForkV11
      [VRFVerKeyHash 'StakePoolVRF] -> ImpTestM era ()
expectVRFs [Item [VRFVerKeyHash 'StakePoolVRF]
VRFVerKeyHash 'StakePoolVRF
vrf2, Item [VRFVerKeyHash 'StakePoolVRF]
VRFVerKeyHash 'StakePoolVRF
vrf3, Item [VRFVerKeyHash 'StakePoolVRF]
VRFVerKeyHash 'StakePoolVRF
vrf5]
  where
    enactHardForkV11 :: ImpTestM era ()
enactHardForkV11 = do
      (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
        PParams era
pp
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      let pv11 :: ProtVer
pv11 = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @11) Natural
0
      NonEmpty (Credential 'HotCommitteeRole)
committee <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      GovActionId
govActionId <- GovAction era -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction (GovAction era -> ImpTestM era GovActionId)
-> GovAction era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ StrictMaybe (GovPurposeId 'HardForkPurpose)
-> ProtVer -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose)
-> ProtVer -> GovAction era
HardForkInitiation StrictMaybe (GovPurposeId 'HardForkPurpose)
forall a. StrictMaybe a
SNothing ProtVer
pv11
      NonEmpty (Credential 'HotCommitteeRole)
-> GovActionId -> ImpTestM era ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committee GovActionId
govActionId
      Natural -> ImpTestM era ()
forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer ImpTestM era ProtVer -> ProtVer -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
pv11
    registerStakePool :: KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ImpM (LedgerSpec era) ()
registerStakePool 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
      Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec 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
.~ [PoolParams -> TxCert era
forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert (PoolParams -> TxCert era) -> PoolParams -> TxCert era
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]
    retireStakePool :: KeyHash 'StakePool -> EpochInterval -> ImpM (LedgerSpec era) ()
retireStakePool 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) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec 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]
    expectVRFs :: [VRFVerKeyHash 'StakePoolVRF] -> ImpTestM era ()
expectVRFs [VRFVerKeyHash 'StakePoolVRF]
vrfs =
      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) -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` [VRFVerKeyHash 'StakePoolVRF] -> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. Ord a => [a] -> Set a
Set.fromList [VRFVerKeyHash 'StakePoolVRF]
vrfs
    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