{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.Ledger.Conway.Imp.SnapSpec (
  spec,
  conwayOnlySpec,
  getSpoVotingStake,
  getDRepVotingStake,
  setupExpiredRefundScenario,
  setupReapedPoolScenario,
  setupWithdrawalScenario,
  setupCombinedScenario,
  getLeaderElectionStake,
  getActiveProposalDeposits,
  isPoolInLeaderDistr,
  isPoolInRewardSnapshot,
  setupRetiredPoolInLeaderDistr,
) where

import Cardano.Ledger.BaseTypes (EpochInterval (..), addEpochInterval)
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Val ((<->))
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Imp.Common

getSpoVotingStake :: ConwayEraImp era => KeyHash StakePool -> ImpTestM era Coin
getSpoVotingStake :: forall era.
ConwayEraImp era =>
KeyHash StakePool -> ImpTestM era Coin
getSpoVotingStake KeyHash StakePool
pool = do
  poolDistr <- PulsingSnapshot era -> Map (KeyHash StakePool) (CompactForm Coin)
forall era.
PulsingSnapshot era -> Map (KeyHash StakePool) (CompactForm Coin)
psPoolDistr (PulsingSnapshot era -> Map (KeyHash StakePool) (CompactForm Coin))
-> (DRepPulsingState era -> PulsingSnapshot era)
-> DRepPulsingState era
-> Map (KeyHash StakePool) (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PulsingSnapshot era, RatifyState era) -> PulsingSnapshot era
forall a b. (a, b) -> a
fst ((PulsingSnapshot era, RatifyState era) -> PulsingSnapshot era)
-> (DRepPulsingState era -> (PulsingSnapshot era, RatifyState era))
-> DRepPulsingState era
-> PulsingSnapshot era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
forall era.
(EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser (DRepPulsingState era
 -> Map (KeyHash StakePool) (CompactForm Coin))
-> ImpM (LedgerSpec era) (DRepPulsingState era)
-> ImpM
     (LedgerSpec era) (Map (KeyHash StakePool) (CompactForm Coin))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) (DRepPulsingState era)
-> ImpM (LedgerSpec era) (DRepPulsingState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((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))
-> ((DRepPulsingState era -> Const r (DRepPulsingState era))
    -> EpochState era -> Const r (EpochState era))
-> (DRepPulsingState era -> Const r (DRepPulsingState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DRepPulsingState era -> Const r (DRepPulsingState era))
-> EpochState era -> Const r (EpochState era)
forall era.
ConwayEraGov era =>
Lens' (EpochState era) (DRepPulsingState era)
Lens' (EpochState era) (DRepPulsingState era)
epochStateDRepPulsingStateL)
  pure $ fromCompact $ poolDistr Map.! pool

getDRepVotingStake :: ConwayEraImp era => Credential DRepRole -> ImpTestM era Coin
getDRepVotingStake :: forall era.
ConwayEraImp era =>
Credential DRepRole -> ImpTestM era Coin
getDRepVotingStake Credential DRepRole
drep = do
  drepDistr <- SimpleGetter (NewEpochState era) (Map DRep (CompactForm Coin))
-> ImpTestM era (Map DRep (CompactForm Coin))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Map DRep (CompactForm Coin))
 -> ImpTestM era (Map DRep (CompactForm Coin)))
-> SimpleGetter (NewEpochState era) (Map DRep (CompactForm Coin))
-> ImpTestM era (Map DRep (CompactForm Coin))
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))
-> ((Map DRep (CompactForm Coin)
     -> Const r (Map DRep (CompactForm Coin)))
    -> EpochState era -> Const r (EpochState era))
-> (Map DRep (CompactForm Coin)
    -> Const r (Map DRep (CompactForm Coin)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DRepPulsingState era -> Const r (DRepPulsingState era))
-> EpochState era -> Const r (EpochState era)
forall era.
ConwayEraGov era =>
Lens' (EpochState era) (DRepPulsingState era)
Lens' (EpochState era) (DRepPulsingState era)
epochStateDRepPulsingStateL ((DRepPulsingState era -> Const r (DRepPulsingState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map DRep (CompactForm Coin)
     -> Const r (Map DRep (CompactForm Coin)))
    -> DRepPulsingState era -> Const r (DRepPulsingState era))
-> (Map DRep (CompactForm Coin)
    -> Const r (Map DRep (CompactForm Coin)))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map DRep (CompactForm Coin)
 -> Const r (Map DRep (CompactForm Coin)))
-> DRepPulsingState era -> Const r (DRepPulsingState era)
forall era.
(EraStake era, ConwayEraAccounts era) =>
SimpleGetter (DRepPulsingState era) (Map DRep (CompactForm Coin))
SimpleGetter (DRepPulsingState era) (Map DRep (CompactForm Coin))
psDRepDistrG
  pure $ fromCompact $ drepDistr Map.! DRepCredential drep

getLeaderElectionStake :: KeyHash StakePool -> ImpTestM era Coin
getLeaderElectionStake :: forall era. KeyHash StakePool -> ImpTestM era Coin
getLeaderElectionStake KeyHash StakePool
pool =
  CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (PoolDistr -> CompactForm Coin) -> PoolDistr -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndividualPoolStake -> CompactForm Coin
individualTotalPoolStake (IndividualPoolStake -> CompactForm Coin)
-> (PoolDistr -> IndividualPoolStake)
-> PoolDistr
-> CompactForm Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) IndividualPoolStake
-> KeyHash StakePool -> IndividualPoolStake
forall k a. Ord k => Map k a -> k -> a
Map.! KeyHash StakePool
pool) (Map (KeyHash StakePool) IndividualPoolStake
 -> IndividualPoolStake)
-> (PoolDistr -> Map (KeyHash StakePool) IndividualPoolStake)
-> PoolDistr
-> IndividualPoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolDistr -> Map (KeyHash StakePool) IndividualPoolStake
unPoolDistr (PoolDistr -> Coin)
-> ImpM (LedgerSpec era) PoolDistr -> ImpM (LedgerSpec era) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) PoolDistr
-> ImpM (LedgerSpec era) PoolDistr
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (PoolDistr -> Const r PoolDistr)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) PoolDistr
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL

getActiveProposalDeposits :: ConwayEraImp era => KeyHash StakePool -> ImpTestM era Coin
getActiveProposalDeposits :: forall era.
ConwayEraImp era =>
KeyHash StakePool -> ImpTestM era Coin
getActiveProposalDeposits KeyHash StakePool
pool = do
  proposals <- SimpleGetter (NewEpochState era) (Proposals era)
-> ImpTestM era (Proposals era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Proposals era)
 -> ImpTestM era (Proposals era))
-> SimpleGetter (NewEpochState era) (Proposals era)
-> ImpTestM era (Proposals 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))
-> ((Proposals era -> Const r (Proposals era))
    -> EpochState era -> Const r (EpochState era))
-> (Proposals era -> Const r (Proposals 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))
-> ((Proposals era -> Const r (Proposals era))
    -> LedgerState era -> Const r (LedgerState era))
-> (Proposals era -> Const r (Proposals era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> Const r (UTxOState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Const r (UTxOState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Proposals era -> Const r (Proposals era))
    -> UTxOState era -> Const r (UTxOState era))
-> (Proposals era -> Const r (Proposals era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era -> Const r (GovState era))
-> UTxOState era -> Const r (UTxOState era)
(ConwayGovState era -> Const r (ConwayGovState era))
-> UTxOState era -> Const r (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL ((ConwayGovState era -> Const r (ConwayGovState era))
 -> UTxOState era -> Const r (UTxOState era))
-> ((Proposals era -> Const r (Proposals era))
    -> ConwayGovState era -> Const r (ConwayGovState era))
-> (Proposals era -> Const r (Proposals era))
-> UTxOState era
-> Const r (UTxOState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proposals era -> Const r (Proposals era))
-> GovState era -> Const r (GovState era)
(Proposals era -> Const r (Proposals era))
-> ConwayGovState era -> Const r (ConwayGovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
Lens' (GovState era) (Proposals era)
proposalsGovStateL
  accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
  pure $
    foldMap fromCompact $
      Map.filterWithKey
        (\Credential Staking
cred CompactForm Coin
_ -> Credential Staking -> Accounts era -> Maybe (KeyHash StakePool)
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Maybe (KeyHash StakePool)
lookupStakePoolDelegation Credential Staking
cred Accounts era
accounts Maybe (KeyHash StakePool) -> Maybe (KeyHash StakePool) -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash StakePool -> Maybe (KeyHash StakePool)
forall a. a -> Maybe a
Just KeyHash StakePool
pool)
        (proposalsDeposits proposals)

setupDelegatorAndPool ::
  ConwayEraImp era => ImpTestM era (KeyHash StakePool, Credential DRepRole, Credential Staking)
setupDelegatorAndPool :: forall era.
ConwayEraImp era =>
ImpTestM
  era (KeyHash StakePool, Credential DRepRole, Credential Staking)
setupDelegatorAndPool = do
  (drep, cred, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
500_000_000
  pool <- freshKeyHash
  registerPool pool
  delegateStake cred pool
  pure (pool, drep, cred)

setupExpiredRefundScenario ::
  ConwayEraImp era => ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupExpiredRefundScenario :: forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupExpiredRefundScenario = 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
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
1
      PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(ConwayEraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1_000_000
  govActionDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
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))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era.
(ConwayEraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL
  (pool, drep, cred) <- setupDelegatorAndPool
  returnAddr <- getAccountAddressFor cred
  govActionId <- submitProposal =<< mkProposalWithAccountAddress InfoAction returnAddr
  expectPresentGovActionId govActionId
  passNEpochs 3
  expectMissingGovActionId govActionId
  pure (pool, drep, govActionDeposit)

setupReapedPoolScenario ::
  ConwayEraImp era => ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupReapedPoolScenario :: forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupReapedPoolScenario = do
  poolDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
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))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL
  (poolActive, drep, cred) <- setupDelegatorAndPool
  registerAndRetirePoolToMakeReward cred
  pure (poolActive, drep, poolDeposit)

setupWithdrawalScenario ::
  ConwayEraImp era => ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupWithdrawalScenario :: forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupWithdrawalScenario = 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
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
30
  committeeCs <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
  (pool, drep, cred) <- setupDelegatorAndPool
  returnAddr <- getAccountAddressFor cred
  submitTx_ $ mkBasicTx mkBasicTxBody & bodyTxL . treasuryDonationTxBodyL .~ Coin 1_000_000
  govActionId <- submitTreasuryWithdrawals [(returnAddr, Coin 1_000_000)]
  submitYesVote_ (DRepVoter drep) govActionId
  submitYesVoteCCs_ committeeCs govActionId
  passNEpochs 2
  expectMissingGovActionId govActionId
  pure (pool, drep, Coin 1_000_000)

setupCombinedScenario ::
  ConwayEraImp era => ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupCombinedScenario :: forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupCombinedScenario = 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
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
1
      PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(ConwayEraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1_000_000
  committeeCs <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
  (poolActive, drep, cred) <- setupDelegatorAndPool
  returnAddr <- getAccountAddressFor cred
  submitTx_ $ mkBasicTx mkBasicTxBody & bodyTxL . treasuryDonationTxBodyL .~ Coin 1_000_000
  infoActionId <- submitProposal =<< mkProposalWithAccountAddress InfoAction returnAddr
  poolToRetire <- freshKeyHash
  registerPoolWithAccountAddress poolToRetire returnAddr
  passEpoch
  curEpochNo <- getsNES nesELL
  submitTxAnn_ "Retire the temporary pool" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.singleton (RetirePoolTxCert poolToRetire (addEpochInterval curEpochNo (EpochInterval 2)))
  modifyPParams $ \PParams era
pp -> PParams era
pp PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
30
  govActionId <- submitTreasuryWithdrawals [(returnAddr, Coin 1_000_000)]
  submitYesVote_ (DRepVoter drep) govActionId
  submitYesVoteCCs_ committeeCs govActionId
  passNEpochs 2
  expectMissingGovActionId infoActionId
  expectMissingGovActionId govActionId
  govActionDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
  poolDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppPoolDepositL
  pure (poolActive, drep, govActionDeposit <> poolDeposit <> Coin 1_000_000)

isPoolInLeaderDistr :: KeyHash StakePool -> ImpTestM era Bool
isPoolInLeaderDistr :: forall era. KeyHash StakePool -> ImpTestM era Bool
isPoolInLeaderDistr KeyHash StakePool
pool = KeyHash StakePool
-> Map (KeyHash StakePool) IndividualPoolStake -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member KeyHash StakePool
pool (Map (KeyHash StakePool) IndividualPoolStake -> Bool)
-> (PoolDistr -> Map (KeyHash StakePool) IndividualPoolStake)
-> PoolDistr
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolDistr -> Map (KeyHash StakePool) IndividualPoolStake
unPoolDistr (PoolDistr -> Bool)
-> ImpM (LedgerSpec era) PoolDistr -> ImpM (LedgerSpec era) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) PoolDistr
-> ImpM (LedgerSpec era) PoolDistr
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (PoolDistr -> Const r PoolDistr)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) PoolDistr
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL

isPoolInRewardSnapshot :: KeyHash StakePool -> ImpTestM era Bool
isPoolInRewardSnapshot :: forall era. KeyHash StakePool -> ImpTestM era Bool
isPoolInRewardSnapshot KeyHash StakePool
pool =
  KeyHash StakePool
-> Map (KeyHash StakePool) IndividualPoolStake -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member KeyHash StakePool
pool (Map (KeyHash StakePool) IndividualPoolStake -> Bool)
-> (GoSnapShot -> Map (KeyHash StakePool) IndividualPoolStake)
-> GoSnapShot
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolDistr -> Map (KeyHash StakePool) IndividualPoolStake
unPoolDistr (PoolDistr -> Map (KeyHash StakePool) IndividualPoolStake)
-> (GoSnapShot -> PoolDistr)
-> GoSnapShot
-> Map (KeyHash StakePool) IndividualPoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShot -> PoolDistr
calculatePoolDistr (SnapShot -> PoolDistr)
-> (GoSnapShot -> SnapShot) -> GoSnapShot -> PoolDistr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GoSnapShot -> SnapShot
gsSnapShot
    (GoSnapShot -> Bool)
-> ImpM (LedgerSpec era) GoSnapShot -> ImpM (LedgerSpec era) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) GoSnapShot
-> ImpM (LedgerSpec era) GoSnapShot
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((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))
-> ((GoSnapShot -> Const r GoSnapShot)
    -> EpochState era -> Const r (EpochState era))
-> (GoSnapShot -> Const r GoSnapShot)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapShots era -> Const r (SnapShots era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(SnapShots era -> f (SnapShots era))
-> EpochState era -> f (EpochState era)
esSnapshotsL ((SnapShots era -> Const r (SnapShots era))
 -> EpochState era -> Const r (EpochState era))
-> ((GoSnapShot -> Const r GoSnapShot)
    -> SnapShots era -> Const r (SnapShots era))
-> (GoSnapShot -> Const r GoSnapShot)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GoSnapShot -> Const r GoSnapShot)
-> SnapShots era -> Const r (SnapShots era)
forall era (f :: * -> *).
Functor f =>
(GoSnapShot -> f GoSnapShot) -> SnapShots era -> f (SnapShots era)
ssStakeGoL)

setupRetiredPoolInLeaderDistr :: ConwayEraImp era => ImpTestM era (KeyHash StakePool)
setupRetiredPoolInLeaderDistr :: forall era. ConwayEraImp era => ImpTestM era (KeyHash StakePool)
setupRetiredPoolInLeaderDistr = do
  (pool, _, _) <- ImpTestM
  era (KeyHash StakePool, Credential DRepRole, Credential Staking)
forall era.
ConwayEraImp era =>
ImpTestM
  era (KeyHash StakePool, Credential DRepRole, Credential Staking)
setupDelegatorAndPool
  passNEpochs 3
  isPoolInLeaderDistr pool `shouldReturn` True
  curEpochNo <- getsNES nesELL
  submitTxAnn_ "Retire the pool" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.singleton (RetirePoolTxCert pool (addEpochInterval curEpochNo (EpochInterval 1)))
  passEpoch
  isPoolInLeaderDistr pool `shouldReturn` True
  pure pool

spec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp 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
"SNAP" (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
"SPO voting stake exceeds leader election stake by the active proposal deposit" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec 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
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
10
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(ConwayEraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1_000_000
    (pool, _paymentCred, stakingCred) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Integer -> Coin
Coin Integer
500_000_000)
    returnAddr <- getAccountAddressFor stakingCred
    _govActionId <- submitProposal =<< mkProposalWithAccountAddress InfoAction returnAddr
    passEpoch
    spoVotingStakeThisEpoch <- getSpoVotingStake pool
    activeProposalDeposits <- getActiveProposalDeposits pool
    passEpoch
    leaderElectionStakeNextEpoch <- getLeaderElectionStake pool
    (spoVotingStakeThisEpoch <-> leaderElectionStakeNextEpoch) `shouldBe` activeProposalDeposits

conwayOnlySpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
conwayOnlySpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
conwayOnlySpec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SNAP" (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
"Reproduces #5014: SPO voting stake lags DRep voting stake by the refunded deposit" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (pool, drep, govActionDeposit) <- ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupExpiredRefundScenario
    drepVotingStake <- getDRepVotingStake drep
    spoVotingStake <- getSpoVotingStake pool
    impAnn "SPO voting stake is behind by the refunded deposit" $
      (drepVotingStake <-> spoVotingStake) `shouldBe` govActionDeposit
    passEpoch
    spoVotingStakeNextEpoch <- getSpoVotingStake pool
    drepVotingStakeNextEpoch <- getDRepVotingStake drep
    impAnn "SPO voting stake catches up in the next epoch" $
      spoVotingStakeNextEpoch `shouldBe` drepVotingStakeNextEpoch

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Reproduces #5014: SPO voting stake lags DRep voting stake by a reaped pool's refunded deposit" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (poolActive, drep, poolDeposit) <- ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupReapedPoolScenario
    drepVotingStake <- getDRepVotingStake drep
    spoVotingStake <- getSpoVotingStake poolActive
    (drepVotingStake <-> spoVotingStake) `shouldBe` poolDeposit

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Reproduces #5014: SPO voting stake lags DRep voting stake by an enacted treasury withdrawal" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$
    ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
      (pool, drep, amount) <- ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupWithdrawalScenario
      drepVotingStake <- getDRepVotingStake drep
      spoVotingStake <- getSpoVotingStake pool
      (drepVotingStake <-> spoVotingStake) `shouldBe` amount

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
    String
"Reproduces #5014: SPO voting stake lags DRep voting stake by the combined refunds and withdrawal"
    (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap
    (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
      (poolActive, drep, combinedDeposit) <- ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupCombinedScenario
      drepVotingStake <- getDRepVotingStake drep
      spoVotingStake <- getSpoVotingStake poolActive
      (drepVotingStake <-> spoVotingStake) `shouldBe` combinedDeposit

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A reaped pool remains in the leader-election distribution for an extra 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
    pool <- ImpTestM era (KeyHash StakePool)
forall era. ConwayEraImp era => ImpTestM era (KeyHash StakePool)
setupRetiredPoolInLeaderDistr
    passEpoch
    isPoolInLeaderDistr pool `shouldReturn` True
    passEpoch
    isPoolInLeaderDistr pool `shouldReturn` False

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A reaped pool remains in the reward stake snapshot for an extra 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
    pool <- ImpTestM era (KeyHash StakePool)
forall era. ConwayEraImp era => ImpTestM era (KeyHash StakePool)
setupRetiredPoolInLeaderDistr
    isPoolInRewardSnapshot pool `shouldReturn` True
    passNEpochs 2
    isPoolInRewardSnapshot pool `shouldReturn` True
    passEpoch
    isPoolInRewardSnapshot pool `shouldReturn` False