diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 9b1c2ec4175..04ac17e036a 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,11 @@ ## 1.17.0.0 +* Refactor pool deposits to use `StakePoolState`. #5234 + * Update `Pool` rule to store deposits in individual `StakePoolState` records + * Add and export `prUTxOStateL`, `prChainAccountStateL`, and `prCertStateL` lenses for `ShelleyPoolreapState` + * Update genesis stake pool registration to use `mempty` deposits for initial pools per specification + * Remove `epochStatePoolParamsL` lens. * Add `hardforkConwayDisallowDuplicatedVRFKeys` * Add `VRFKeyHashAlreadyRegistered` to `ShelleyPoolPredFailure` type * Add `NFData` for `NominalDiffTimeMicro`, `ShelleyGenesisStaking` and `ShelleyGenesis` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs index 7c68f5d802f..2b23b3c1df7 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs @@ -42,8 +42,6 @@ module Cardano.Ledger.Shelley.LedgerState ( produced, -- * DelegationState - payPoolDeposit, - refundPoolDeposit, totalObligation, allObligations, @@ -102,7 +100,6 @@ module Cardano.Ledger.Shelley.LedgerState ( utxosDonationL, epochStateGovStateL, epochStateStakeDistrL, - epochStatePoolParamsL, epochStateStakePoolsL, epochStateDonationL, newEpochStateGovStateL, @@ -115,7 +112,7 @@ module Cardano.Ledger.Shelley.LedgerState ( psStakePoolsL, psFutureStakePoolsL, psRetiringL, - psDepositsL, + psDepositsG, psVRFKeyHashesL, -- * Lenses from SnapShot(s) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs index 6280d4a5d3d..d51c1f663c3 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs @@ -55,7 +55,7 @@ import Control.Monad.State.Strict (evalStateT) import Control.Monad.Trans (MonadTrans (lift)) import Data.Aeson (ToJSON (..), (.=)) import Data.Default (Default, def) -import Data.Map.Strict (Map, mapWithKey) +import Data.Map.Strict (Map) import Data.VMap (VB, VMap, VP) import GHC.Generics (Generic) import Lens.Micro @@ -698,12 +698,6 @@ epochStateStakePoolsL :: EraCertState era => Lens' (EpochState era) (Map (KeyHash 'StakePool) StakePoolState) epochStateStakePoolsL = esLStateL . lsCertStateL . certPStateL . psStakePoolsL -epochStatePoolParamsL :: - EraCertState era => Lens' (EpochState era) (Map (KeyHash 'StakePool) PoolParams) -epochStatePoolParamsL = - epochStateStakePoolsL . lens (mapWithKey stakePoolStateToPoolParams) (const $ fmap mkStakePoolState) -{-# DEPRECATED epochStatePoolParamsL "In favor of `epochStateStakePoolsL`" #-} - epochStateStakeDistrL :: Lens' (EpochState era) (VMap VB VP (Credential 'Staking) (CompactForm Coin)) epochStateStakeDistrL = esSnapshotsL . ssStakeMarkL . ssStakeDistrL diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs index fca00d9c308..4ecfcfb1292 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -259,10 +259,9 @@ poolDelegationTransition = do | otherwise = id tellEvent $ RegisterPool ppId pure $ - payPoolDeposit ppId pp $ - ps - & psStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams) - & psVRFKeyHashesL %~ updateVRFKeyHash + ps + & psStakePoolsL %~ Map.insert ppId (mkStakePoolState (pp ^. ppPoolDepositCompactL) poolParams) + & psVRFKeyHashesL %~ updateVRFKeyHash -- re-register Pool Just stakePoolState -> do when (hardforkConwayDisallowDuplicatedVRFKeys pv) $ do @@ -281,18 +280,21 @@ poolDelegationTransition = do | otherwise -> id | otherwise = id tellEvent $ ReregisterPool ppId - -- hk is already registered, so we want to reregister it. That means adding it - -- to the Future pool params (if it is not there already), and overriding the - -- range with the new 'poolParam', if it is (using ⨃ ). We must also unretire - -- it, if it has been scheduled for retirement. The deposit does not - -- change. One pays the deposit just once. Only if it is fully retired - -- (i.e. it's deposit has been refunded, and it has been removed from the - -- registered pools). does it need to pay a new deposit (at the current deposit - -- amount). But of course, if that has happened, we cannot be in this branch of - -- the if statement. + -- NOTE: The `ppId` is already registered, so we want to reregister + -- it. That means adding it to the Future Stake Pools (if it is not + -- there already), and overriding its range with the new 'poolParams', + -- if it is. + -- + -- We must also unretire it, if it has been scheduled for retirement. + -- + -- The deposit does not change. One pays the deposit just once. Only + -- if it is fully retired (i.e. it's deposit has been refunded, and it + -- has been removed from the registered pools). does it need to pay a + -- new deposit (at the current deposit amount). But of course, if that + -- has happened, we cannot be in this branch of the case statement. pure $ ps - & psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams) + & psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState (stakePoolState ^. spsDepositL) poolParams) & psRetiringL %~ Map.delete ppId & psVRFKeyHashesL %~ updateFutureVRFKeyHash RetirePool ppId e -> do diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs index 3c1bd557a9e..76e30e71ae2 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs @@ -16,11 +16,14 @@ module Cardano.Ledger.Shelley.Rules.PoolReap ( ShelleyPOOLREAP, ShelleyPoolreapEvent (..), ShelleyPoolreapState (..), + prCertStateL, + prChainAccountStateL, + prUTxOStateL, PredicateFailure, ShelleyPoolreapPredFailure, ) where -import Cardano.Ledger.Address (RewardAccount, raCredential) +import Cardano.Ledger.Address import Cardano.Ledger.BaseTypes (ShelleyBase) import Cardano.Ledger.Coin (Coin, CompactForm) import Cardano.Ledger.Compactible (fromCompact) @@ -65,6 +68,15 @@ data ShelleyPoolreapState era = PoolreapState deriving stock instance (Show (UTxOState era), Show (CertState era)) => Show (ShelleyPoolreapState era) +prUTxOStateL :: Lens' (ShelleyPoolreapState era) (UTxOState era) +prUTxOStateL = lens prUTxOSt $ \sprs x -> sprs {prUTxOSt = x} + +prChainAccountStateL :: Lens' (ShelleyPoolreapState era) ChainAccountState +prChainAccountStateL = lens prChainAccountState $ \sprs x -> sprs {prChainAccountState = x} + +prCertStateL :: Lens' (ShelleyPoolreapState era) (CertState era) +prCertStateL = lens prCertState $ \sprs x -> sprs {prCertState = x} + data ShelleyPoolreapPredFailure era -- No predicate failures deriving (Show, Eq, Generic) @@ -155,38 +167,37 @@ poolReapTransition = do -- The set of pools retiring this epoch retired :: Set (KeyHash 'StakePool) retired = Set.fromDistinctAscList [k | (k, v) <- Map.toAscList (psRetiring ps), v == e] - -- The Map of pools (retiring this epoch) to their deposits - retiringDeposits, remainingDeposits :: Map.Map (KeyHash 'StakePool) (CompactForm Coin) - (retiringDeposits, remainingDeposits) = - Map.partitionWithKey (\k _ -> Set.member k retired) (psDeposits ps) + -- The Map of pools retiring this epoch + retiringPools :: Map.Map (KeyHash 'StakePool) StakePoolState + retiringPools = Map.restrictKeys (psStakePools ps) retired -- collect all accounts for stake pools that will retire retiredStakePoolAccountsWithVRFs :: Map.Map (KeyHash 'StakePool) (RewardAccount, VRFVerKeyHash 'StakePoolVRF) retiredStakePoolAccountsWithVRFs = Map.map (\sps -> (spsRewardAccount sps, spsVrf sps)) - $ Map.restrictKeys (psStakePools ps) retired + retiringPools retiredVRFs = foldMap (Set.singleton . snd) retiredStakePoolAccountsWithVRFs retiredStakePoolAccountsWithRefund :: Map.Map (KeyHash 'StakePool) (RewardAccount, CompactForm Coin) retiredStakePoolAccountsWithRefund = Map.intersectionWith - (\(rewardAccount, _) coin -> (rewardAccount, coin)) + (\(rewardAccount, _) sps -> (rewardAccount, spsDeposit sps)) retiredStakePoolAccountsWithVRFs - retiringDeposits + retiringPools -- collect all of the potential refunds accountRefunds :: Map.Map (Credential 'Staking) (CompactForm Coin) accountRefunds = Map.fromListWith (<>) $ [(raCredential k, v) | (k, v) <- Map.elems retiredStakePoolAccountsWithRefund] accounts = ds ^. accountsL - -- figure out whcich deposits can be refunded and which ones will be deposited into the treasury - -- as unclaimed + -- Deposits that can be refunded and those that are unclaimed (to be deposited into the treasury). refunds, unclaimedDeposits :: Map.Map (Credential 'Staking) (CompactForm Coin) (refunds, unclaimedDeposits) = Map.partitionWithKey (\stakeCred _ -> isAccountRegistered stakeCred accounts) -- (k ∈ dom (rewards ds)) accountRefunds + refunded = fold refunds unclaimed = fold unclaimedDeposits @@ -216,7 +227,6 @@ poolReapTransition = do %~ removeStakePoolDelegations retired . addToBalanceAccounts refunds & certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retired) & certPStateL . psRetiringL %~ (`Map.withoutKeys` retired) - & certPStateL . psDepositsCompactL .~ remainingDeposits & certPStateL . psVRFKeyHashesL %~ ((`Set.difference` retiredVRFs) . (`Set.difference` danglingVrfKeyHashes)) ) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs index 31ee05cb263..13ed810cac2 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs @@ -30,6 +30,7 @@ import Cardano.Ledger.Binary ( encodeListLen, ) import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Compactible (fromCompact) import Cardano.Ledger.Core import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Shelley.Era (ShelleyEra) @@ -77,7 +78,8 @@ shelleyObligationCertState :: EraCertState era => CertState era -> Obligations shelleyObligationCertState certState = Obligations { oblStake = sumDepositsAccounts (certState ^. certDStateL . accountsL) - , oblPool = F.foldl' (<>) (Coin 0) (certState ^. certPStateL . psDepositsL) + , oblPool = + F.foldl' (<>) (Coin 0) (fromCompact . spsDeposit <$> certState ^. certPStateL . psStakePoolsL) , oblDRep = Coin 0 , oblProposal = Coin 0 } diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs index 7e4353bca34..580de4e24c7 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs @@ -385,6 +385,18 @@ createInitialState tc = reserves :: Coin reserves = word64ToCoin (sgMaxLovelaceSupply sg) <-> sumCoinUTxO initialUtxo +-- | From the haddock for `ShelleyGenesisStaking`: +-- +-- > `ShelleyGenesisStaking` allows us to configure some initial stake pools and +-- > delegation to them, in order to test Praos in a static configuration, without +-- > requiring on-chain registration and delegation. +-- +-- > For simplicity, pools defined in the genesis staking DO NOT PAY DEPOSITS FOR +-- > THEIR REGISTRATION +-- +-- Therefore, we use `mempty` in the convertion below. +-- +-- QUESTION: @aniketd: Is the assumption that we can use mempty truly harmless? registerInitialStakePools :: forall era. EraCertState era => @@ -394,7 +406,7 @@ registerInitialStakePools :: registerInitialStakePools ShelleyGenesisStaking {sgsPools} nes = nes & nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL - .~ (mkStakePoolState <$> ListMap.toMap sgsPools) + .~ (mkStakePoolState mempty <$> ListMap.toMap sgsPools) -- | Register all staking credentials and apply delegations. Make sure StakePools that are bing -- delegated to are already registered, which can be done with `registerInitialStakePools`. diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/UnitTests/InstantStakeTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/UnitTests/InstantStakeTest.hs index 1bc99e6adf0..027e3eac9f2 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/UnitTests/InstantStakeTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/UnitTests/InstantStakeTest.hs @@ -85,7 +85,7 @@ instantStakeIncludesRewards = do instantStake = addInstantStake utxo1 mempty poolparamMap = Map.fromList [(poolId1, pool1), (poolId2, pool2)] - pState <- arbitraryLens psStakePoolsL $ mkStakePoolState <$> poolparamMap + pState <- arbitraryLens psStakePoolsL $ mkStakePoolState mempty <$> poolparamMap let snapShot = snapShotFromInstantStake instantStake dState pState computedStakeDistr = VMap.toMap (unStake (ssStake snapShot)) diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs index da8e15a7cb9..9e565d71b75 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs @@ -236,8 +236,8 @@ checkPreservation SourceSignalTarget {source, target, signal} count = oldCertState = lsCertState lsOld oldRetire = lsOld ^. lsCertStateL . certPStateL . psRetiringL newRetire = lsNew ^. lsCertStateL . certPStateL . psRetiringL - oldPoolDeposit = lsOld ^. lsCertStateL . certPStateL . psDepositsL - newPoolDeposit = lsNew ^. lsCertStateL . certPStateL . psDepositsL + oldPoolDeposit = spsDeposit <$> lsOld ^. lsCertStateL . certPStateL . psStakePoolsL + newPoolDeposit = spsDeposit <$> lsNew ^. lsCertStateL . certPStateL . psStakePoolsL proposal = votedFuturePParams (sgsCurProposals . utxosGovState $ lsUTxOState lsOld) currPP 5 obligationMsgs = case proposal of diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deposits.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deposits.hs index 4242373d951..157f5e06689 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deposits.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deposits.hs @@ -80,7 +80,7 @@ depositInvariant SourceSignalTarget {source = chainSt} = pstate = certState ^. certPStateL allDeposits = utxosDeposited utxost keyDeposits = sumDepositsAccounts (dstate ^. accountsL) - poolDeposits = foldMap fromCompact (psDeposits pstate) + poolDeposits = foldMap (fromCompact . spsDeposit) (psStakePools pstate) in counterexample ( ansiDocToString . Pretty.vsep $ [ "Deposit invariant fails:" @@ -88,7 +88,7 @@ depositInvariant SourceSignalTarget {source = chainSt} = [ "All deposits = " ++ show allDeposits , "Key deposits = " ++ show ((^. depositAccountStateL) <$> (dstate ^. accountsL . accountsMapL)) - , "Pool deposits = " ++ synopsisCoinMap (Just (fromCompact <$> psDeposits pstate)) + , "Pool deposits = " ++ synopsisCoinMap (Just (fromCompact . spsDeposit <$> psStakePools pstate)) ] ] ) diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs index 76f379ef094..4a5b4d781e2 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -25,6 +25,7 @@ import Cardano.Protocol.TPraos.BHeader (bhbody, bheaderSlotNo) import Control.SetAlgebra (dom, eval, (∈), (∉)) import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import Lens.Micro import Lens.Micro.Extras (view) import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto) import Test.Cardano.Ledger.Shelley.Constants (defaultConstants) @@ -131,25 +132,27 @@ poolRegistrationProp , target = targetSt } = let hk = ppId poolParams - reRegistration = eval (hk ∈ dom (psStakePools sourceSt)) - in if reRegistration - then + in case Map.lookup hk $ psStakePools sourceSt of + Just sps -> conjoin [ counterexample "Pre-existing PoolParams must still be registered in pParams" (eval (hk ∈ dom (psStakePools targetSt)) :: Bool) , counterexample "New PoolParams are registered in future Params map" - (Map.lookup hk (psFutureStakePools targetSt) === Just (mkStakePoolState poolParams)) + ( Map.lookup hk (psFutureStakePools targetSt) + === Just (mkStakePoolState (sps ^. spsDepositL) poolParams) + ) , counterexample "PoolParams are removed in 'retiring'" (eval (hk ∉ dom (psRetiring targetSt)) :: Bool) ] - else -- first registration + Nothing -> + -- first registration conjoin [ counterexample "New PoolParams are registered in pParams" - (Map.lookup hk (psStakePools targetSt) === Just (mkStakePoolState poolParams)) + (Map.lookup hk (psStakePools targetSt) === Just (mkStakePoolState mempty poolParams)) , counterexample "PoolParams are not present in 'future pool params'" (eval (hk ∉ dom (psFutureStakePools targetSt)) :: Bool) diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs index f4bbe20035b..88ef9c323b1 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs @@ -14,13 +14,11 @@ module Test.Cardano.Ledger.Shelley.Examples.Combinators ( evolveNonceUnfrozen, newLab, addFees, - addPoolDeposits, newUTxO, newStakeCred, deregStakeCred, delegation, - newPool, - reregPool, + regPool, updatePoolParams, stageRetirement, reapPool, @@ -81,7 +79,7 @@ import Cardano.Ledger.Shelley.LedgerState ( import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates) import Cardano.Ledger.Shelley.Rules (emptyInstantaneousRewards, votedFuturePParams) import Cardano.Ledger.Shelley.State -import Cardano.Ledger.Val ((<+>), (<->), (<×>)) +import Cardano.Ledger.Val ((<+>), (<->)) import Cardano.Protocol.TPraos.BHeader ( BHBody (..), BHeader, @@ -95,7 +93,6 @@ import Cardano.Slotting.Slot (EpochNo, WithOrigin (..)) import Data.Foldable (fold) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.MapExtras (fromElems) import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.Word (Word64) @@ -146,26 +143,6 @@ newLab b cs = bn = bheaderBlockNo $ bhbody bh sn = bheaderSlotNo $ bhbody bh --- | Add new pools while updating the deposit pot -addPoolDeposits :: - forall era. - (EraPParams era, EraCertState era) => - PParams era -> - [PoolParams] -> - ChainState era -> - ChainState era -addPoolDeposits ppEx pools cs = cs {chainNes = nes} - where - curDeposits = - chainNes cs ^. nesEsL . esLStateL . lsCertStateL . certPStateL . psDepositsL - nes = - chainNes cs - & nesEsL . esLStateL . lsCertStateL . certPStateL . psDepositsL %~ Map.union newPools - & nesEsL . esLStateL . lsUTxOStateL . utxosDepositedL <>~ (newPoolCount <×> ppEx ^. ppPoolDepositL) - -- Count the number of new pools, because we don't take a deposit for existing pools - newPools = ppEx ^. ppPoolDepositL <$ (fromElems ppId pools `Map.difference` curDeposits) - newPoolCount = Map.size newPools - addFees :: Coin -> ChainState era -> @@ -258,58 +235,56 @@ delegation cred poolId cs = cs {chainNes = nes} & nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL . accountsMapL %~ Map.adjust (stakePoolDelegationAccountStateL .~ Just poolId) cred --- | = New Stake Pool --- --- Add a newly registered stake pool -newPool :: - forall era. - EraCertState era => - PoolParams -> - ChainState era -> - ChainState era -newPool pool cs = cs {chainNes = nes'} - where - nes = chainNes cs - es = nesEs nes - ls = esLState es - dps = lsCertState ls - ps = dps ^. certPStateL - ps' = - ps - { psStakePools = Map.insert (ppId pool) (mkStakePoolState pool) (psStakePools ps) - } - dps' = dps & certPStateL .~ ps' - ls' = ls {lsCertState = dps'} - es' = es {esLState = ls'} - nes' = nes {nesEs = es'} - --- | = Re-Register Stake Pool -reregPool :: +-- | Register a stake pool. +regPool :: forall era. - EraCertState era => + ( EraCertState era + , EraGov era + ) => PoolParams -> ChainState era -> ChainState era -reregPool pool cs = cs {chainNes = nes'} +regPool pool cs = cs {chainNes = nes'} where nes = chainNes cs es = nesEs nes ls = esLState es dps = lsCertState ls ps = dps ^. certPStateL + poolDeposit = es ^. curPParamsEpochStateL . ppPoolDepositCompactL ps' = - ps - { psFutureStakePools = Map.insert (ppId pool) (mkStakePoolState pool) (psStakePools ps) - } + case Map.lookup (ppId pool) $ psStakePools ps of + Nothing -> + ps + { psStakePools = + Map.insert + (ppId pool) + (mkStakePoolState poolDeposit pool) + (psStakePools ps) + } + Just sps -> + ps + { psFutureStakePools = + Map.insert + (ppId pool) + (mkStakePoolState (spsDeposit sps) pool) + (psFutureStakePools ps) + } dps' = dps & certPStateL .~ ps' ls' = ls {lsCertState = dps'} - es' = es {esLState = ls'} + ls'' = + ls' + & lsUTxOStateL . utxosDepositedL + <>~ maybe (fromCompact poolDeposit) (const $ Coin 0) (Map.lookup (ppId pool) (psStakePools ps)) + es' = es {esLState = ls''} nes' = nes {nesEs = es'} -- | = Re-Register Stake Pool updatePoolParams :: forall era. - EraCertState era => + ( EraCertState era + , EraGov era + ) => PoolParams -> ChainState era -> ChainState era @@ -322,7 +297,11 @@ updatePoolParams pool cs = cs {chainNes = nes'} ps = dps ^. certPStateL ps' = ps - { psStakePools = Map.insert (ppId pool) (mkStakePoolState pool) (psStakePools ps) + { psStakePools = + Map.insert + (ppId pool) + (mkStakePoolState (es ^. curPParamsEpochStateL . ppPoolDepositCompactL) pool) + (psStakePools ps) , psFutureStakePools = Map.delete (ppId pool) (psStakePools ps) } dps' = dps & certPStateL .~ ps' @@ -370,12 +349,11 @@ reapPool pool cs = cs {chainNes = nes'} ls = esLState es dps = lsCertState ls ps = dps ^. certPStateL - poolDeposit = fromJust $ Map.lookup poolId (psDeposits ps) + poolDeposit = spsDeposit $ fromJust $ Map.lookup poolId (psStakePools ps) ps' = ps { psRetiring = Map.delete poolId (psRetiring ps) , psStakePools = Map.delete poolId (psStakePools ps) - , psDeposits = Map.delete poolId (psDeposits ps) , psVRFKeyHashes = Set.delete (ppVrf pool) (psVRFKeyHashes ps) } pp = es ^. curPParamsEpochStateL diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs index d9b79caf3ff..2f2a89d5242 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs @@ -240,12 +240,11 @@ expectedStEx1 = C.evolveNonceUnfrozen (getBlockNonce blockEx1) . C.newLab blockEx1 . C.addFees feeTx1 - . C.addPoolDeposits ppEx [Cast.alicePoolParams] . C.newUTxO txbodyEx1 . C.newStakeCred Cast.aliceSHK (Ptr (SlotNo32 10) minBound (mkCertIxPartial 0)) . C.newStakeCred Cast.bobSHK (Ptr (SlotNo32 10) minBound (mkCertIxPartial 1)) . C.newStakeCred Cast.carlSHK (Ptr (SlotNo32 10) minBound (mkCertIxPartial 2)) - . C.newPool Cast.alicePoolParams + . C.regPool Cast.alicePoolParams . C.mir Cast.carlSHK ReservesMIR carlMIR . C.mir Cast.dariaSHK ReservesMIR dariaMIR $ initStPoolLifetime diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs index fdd2dab49ef..80a031ccb90 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs @@ -131,9 +131,8 @@ expectedStEx1 = C.evolveNonceUnfrozen (getBlockNonce blockEx1) . C.newLab blockEx1 . C.addFees feeTx1 - . C.addPoolDeposits ppEx [Cast.alicePoolParams] . C.newUTxO txbodyEx1 - . C.newPool Cast.alicePoolParams + . C.regPool Cast.alicePoolParams $ initStPoolReReg -- === Block 1, Slot 10, Epoch 0 @@ -211,9 +210,8 @@ blockEx2A = blockEx2 20 expectedStEx2 :: ChainState ShelleyEra expectedStEx2 = C.addFees feeTx2 - . C.addPoolDeposits ppEx [newPoolParams] -- The deposit should be ignored because the poolId is already registered . C.newUTxO txbodyEx2 - . C.reregPool newPoolParams + . C.regPool newPoolParams $ expectedStEx1 expectedStEx2A :: ChainState ShelleyEra diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs index 08a74c21931..b0c53e2ed0c 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs @@ -233,13 +233,12 @@ expectedStEx1 = C.evolveNonceUnfrozen (getBlockNonce blockEx1) . C.newLab blockEx1 . C.addFees feeTx1 - . C.addPoolDeposits ppEx [alicePoolParams', bobPoolParams'] . C.newUTxO txbodyEx1 . C.newStakeCred Cast.aliceSHK (Ptr (SlotNo32 10) minBound (mkCertIxPartial 0)) . C.newStakeCred Cast.bobSHK (Ptr (SlotNo32 10) minBound (mkCertIxPartial 1)) . C.newStakeCred Cast.carlSHK (Ptr (SlotNo32 10) minBound (mkCertIxPartial 2)) - . C.newPool alicePoolParams' - . C.newPool bobPoolParams' + . C.regPool alicePoolParams' + . C.regPool bobPoolParams' . C.delegation Cast.aliceSHK (ppId alicePoolParams') . C.delegation Cast.bobSHK (ppId bobPoolParams') . C.delegation Cast.carlSHK (ppId alicePoolParams') diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs index 6ca3d8e2268..1d53f4c7701 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs @@ -1084,18 +1084,17 @@ tests = actualHex = B16.encode actual expectedHex = mconcat - [ "8700a1581ce0a714319812c3f773ba04ec5d6b3ffcd5aad85006805b047b0825410aa158" - , "1ca646474b8f5431261506b6c273d307c7569a4eb6c96b42dd4a29520a03848219271019" - , "03e882828580a0a0a0a08482a0a0a0a084a0a0000086a15822ee155ace9c40292074cb6aff" - , "8c9ccdd273c81648ff1149ef36bcea6ebb8a3e250000583d003900cb9358529df4729c32" - , "46a2a033cb9821abbfd16de4888005904abc410d6a577e9441ad8ed9663931906e4d43ec" - , "e8f82c712b1d0235affb06000a1903e80185a0a091000000190800000000001864d81e82" - , "0001d81e820001d81e820001d81e8200018100820200010091000000190800000000001864" - , "d81e820001d81e820001d81e820001d81e82000181008202000000810082a0a0008483a0a0" - , "a083a0a0a083a0a0a00082a000818300880082020082a000000000a0a0840185a0800082" - , "0200a0a082a0a082a1581ce0a714319812c3f773ba04ec5d6b3ffcd5aad85006805b047b" - , "08254183820101015820c5e21ab1c9f6022d81c3b25e3436cb7f1df77f9652ae3e1310c2" - , "8e621dd87b4c01a0" + [ "8700a1581ce0a714319812c3f773ba04ec5d6b3ffcd5aad85006805b047b0825410aa1581ca64647" + , "4b8f5431261506b6c273d307c7569a4eb6c96b42dd4a29520a0384821927101903e882828480a0a0" + , "a08482a0a0a0a084a0a0000086a15822ee155ace9c40292074cb6aff8c9ccdd273c81648ff1149ef" + , "36bcea6ebb8a3e250000583d003900cb9358529df4729c3246a2a033cb9821abbfd16de488800590" + , "4abc410d6a577e9441ad8ed9663931906e4d43ece8f82c712b1d0235affb06000a1903e80185a0a0" + , "91000000190800000000001864d81e820001d81e820001d81e820001d81e82000181008202000100" + , "91000000190800000000001864d81e820001d81e820001d81e820001d81e82000181008202000000" + , "810082a0a0008483a0a0a083a0a0a083a0a0a00082a000818300880082020082a000000000a0a084" + , "0185a08000820200a0a082a0a082a1581ce0a714319812c3f773ba04ec5d6b3ffcd5aad85006805b" + , "047b08254183820101015820c5e21ab1c9f6022d81c3b25e3436cb7f1df77f9652ae3e1310c28e62" + , "1dd87b4c01a0" ] in testCase "ledger state golden test" $ unless (actual == expected) $ diff --git a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Cert.hs b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Cert.hs index 4ab6132e1b0..1fcbc4ff06e 100644 --- a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Cert.hs +++ b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Cert.hs @@ -88,7 +88,7 @@ depositsMap certState props = , bimapMHSMap (fmap Agda.PoolDeposit . toSpecRep) toSpecRep - (Agda.MkHSMap . Map.toList $ certState ^. certPStateL . psDepositsL) + (Agda.MkHSMap . Map.toList $ fromCompact . spsDeposit <$> certState ^. certPStateL . psStakePoolsL) , bimapMHSMap (fmap Agda.DRepDeposit . toSpecRep) (toSpecRep . drepDeposit) diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 61939fa69dc..dd76f2880dd 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,14 @@ ## 1.18.0.0 +* Move pool deposits from `PState` into `StakePoolState`. #5234 + * Add `spsDeposit` field to `StakePoolState` + * Remove `psDeposits` field from `PState` data constructor + * Update `mkStakePoolState` to take deposit parameter as first argument + * Replace `psDepositsL` and `psDepositsCompactL` lenses with `psDepositsG` and `psDepositsCompactG` getters + * Remove `payPoolDeposit` and `refundPoolDeposit` functions as they are no longer necessary + * Update `EncCBOR`/`DecCBOR` instances for `PState` to handle new structure + * Add lenses for `StakePoolState` fields * Add `psVRFKeyHashes` to `PState` * Add `psVRFKeyHashesL` * Deprecate `costModelParamsCount` in favor of `costModelInitParamCount` diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs index c96a021df9a..d7140dba42c 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs @@ -32,8 +32,6 @@ module Cardano.Ledger.State.CertState ( AnchorData, lookupDepositDState, lookupRewardDState, - payPoolDeposit, - refundPoolDeposit, Obligations (..), sumObligation, -- Lenses @@ -43,8 +41,8 @@ module Cardano.Ledger.State.CertState ( psStakePoolsL, psFutureStakePoolsL, psRetiringL, - psDepositsL, - psDepositsCompactL, + psDepositsG, + psDepositsCompactG, psVRFKeyHashesL, ) where @@ -71,7 +69,7 @@ import Cardano.Ledger.Binary ( toMemptyLens, ) import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), ( EncCBOR (PState era) where - encCBOR (PState a b c d e) = - encodeListLen 5 <> encCBOR a <> encCBOR b <> encCBOR c <> encCBOR d <> encCBOR e + encCBOR (PState a b c d) = + encodeListLen 4 <> encCBOR a <> encCBOR b <> encCBOR c <> encCBOR d instance DecShareCBOR (PState era) where type Share (PState era) = Interns (KeyHash 'StakePool) - decSharePlusCBOR = decodeRecordNamedT "PState" (const 5) $ do + decSharePlusCBOR = decodeRecordNamedT "PState" (const 4) $ do psVRFKeyHashes <- lift decCBOR psStakePools <- decSharePlusLensCBOR (toMemptyLens _1 id) psFutureStakePools <- decSharePlusLensCBOR (toMemptyLens _1 id) psRetiring <- decSharePlusLensCBOR (toMemptyLens _1 id) - psDeposits <- decSharePlusLensCBOR (toMemptyLens _1 id) - pure PState {psVRFKeyHashes, psStakePools, psFutureStakePools, psRetiring, psDeposits} + pure PState {psVRFKeyHashes, psStakePools, psFutureStakePools, psRetiring} instance (Era era, DecShareCBOR (PState era)) => DecCBOR (PState era) where decCBOR = decNoShareCBOR @@ -272,7 +265,6 @@ instance ToKeyValuePairs (PState era) where , "stakePools" .= psStakePools , "futureStakePools" .= psFutureStakePools , "retiring" .= psRetiring - , "deposits" .= psDeposits ] data CommitteeAuthorization @@ -402,35 +394,7 @@ instance Default (Accounts era) => Default (DState era) where instance Default (PState era) where def = - PState Set.empty Map.empty Map.empty Map.empty Map.empty - --- ========================================================== --- Functions that handle Deposits - --- | One only pays a deposit on the initial pool registration. So return the --- the Deposits unchanged if the keyhash already exists. There are legal --- situations where a pool may be registered multiple times. -payPoolDeposit :: - EraPParams era => - KeyHash 'StakePool -> - PParams era -> - PState era -> - PState era -payPoolDeposit keyhash pp pstate = pstate {psDeposits = newpool} - where - pool = psDeposits pstate - !deposit = pp ^. ppPoolDepositCompactL - newpool - | Map.notMember keyhash pool = Map.insert keyhash deposit pool - | otherwise = pool - -refundPoolDeposit :: KeyHash 'StakePool -> PState era -> (CompactForm Coin, PState era) -refundPoolDeposit keyhash pstate = (coin, pstate {psDeposits = newpool}) - where - pool = psDeposits pstate - (coin, newpool) = case Map.lookup keyhash pool of - Just c -> (c, Map.delete keyhash pool) - Nothing -> (mempty, pool) + PState Set.empty Map.empty Map.empty Map.empty -- | A composite of all the Deposits the system is obligated to eventually pay back. data Obligations = Obligations @@ -468,12 +432,6 @@ instance Show Obligations where , " Proposal deposits = " ++ show (oblProposal x) ] --- ======================================================= --- Lenses for CertState and its subsidiary types - --- =================================== --- DState - dsGenDelegsL :: Lens' (DState era) GenDelegs dsGenDelegsL = lens dsGenDelegs (\ds u -> ds {dsGenDelegs = u}) @@ -484,9 +442,6 @@ dsFutureGenDelegsL :: Lens' (DState era) (Map FutureGenDeleg GenDelegPair) dsFutureGenDelegsL = lens dsFutureGenDelegs (\ds u -> ds {dsFutureGenDelegs = u}) --- =================================== --- PState - psStakePoolsL :: Lens' (PState era) (Map (KeyHash 'StakePool) StakePoolState) psStakePoolsL = lens psStakePools (\ps u -> ps {psStakePools = u}) @@ -496,11 +451,11 @@ psFutureStakePoolsL = lens psFutureStakePools (\ps u -> ps {psFutureStakePools = psRetiringL :: Lens' (PState era) (Map (KeyHash 'StakePool) EpochNo) psRetiringL = lens psRetiring (\ps u -> ps {psRetiring = u}) -psDepositsL :: Lens' (PState era) (Map (KeyHash 'StakePool) Coin) -psDepositsL = psDepositsCompactL . lens (fmap fromCompact) (\_ -> fmap compactCoinOrError) +psDepositsCompactG :: SimpleGetter (PState era) (Map (KeyHash 'StakePool) (CompactForm Coin)) +psDepositsCompactG = to (fmap spsDeposit . psStakePools) -psDepositsCompactL :: Lens' (PState era) (Map (KeyHash 'StakePool) (CompactForm Coin)) -psDepositsCompactL = lens psDeposits (\ps u -> ps {psDeposits = u}) +psDepositsG :: SimpleGetter (PState era) (Map (KeyHash 'StakePool) Coin) +psDepositsG = psDepositsCompactG . to (fmap fromCompact) psVRFKeyHashesL :: Lens' (PState era) (Set (VRFVerKeyHash 'StakePoolVRF)) psVRFKeyHashesL = lens psVRFKeyHashes (\ps u -> ps {psVRFKeyHashes = u}) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs index 74b33bcada5..8e72e0d6ff3 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs @@ -27,6 +27,17 @@ module Cardano.Ledger.State.StakePool ( -- * Stake Pool State StakePoolState (..), + -- * Lenses + spsVrfL, + spsPledgeL, + spsCostL, + spsMarginL, + spsRewardAccountL, + spsOwnersL, + spsRelaysL, + spsMetadataL, + spsDepositL, + -- * Conversions mkStakePoolState, stakePoolStateToPoolParams, @@ -43,7 +54,6 @@ module Cardano.Ledger.State.StakePool ( ppCostL, ppMetadataL, ppVrfL, - spsVrfL, ) where import Cardano.Ledger.Address (RewardAccount) @@ -81,7 +91,7 @@ import Cardano.Ledger.Binary.Coders ( (!>), ( sps {spsVrf = u}) -deriving instance NoThunks StakePoolState +spsPledgeL :: Lens' StakePoolState Coin +spsPledgeL = lens spsPledge $ \sps c -> sps {spsPledge = c} + +spsCostL :: Lens' StakePoolState Coin +spsCostL = lens spsCost $ \sps c -> sps {spsCost = c} -deriving instance NFData StakePoolState +spsMarginL :: Lens' StakePoolState UnitInterval +spsMarginL = lens spsMargin $ \sps m -> sps {spsMargin = m} -deriving instance ToJSON StakePoolState +spsRewardAccountL :: Lens' StakePoolState RewardAccount +spsRewardAccountL = lens spsRewardAccount $ \sps ra -> sps {spsRewardAccount = ra} -deriving instance FromJSON StakePoolState +spsOwnersL :: Lens' StakePoolState (Set (KeyHash 'Staking)) +spsOwnersL = lens spsOwners $ \sps s -> sps {spsOwners = s} + +spsRelaysL :: Lens' StakePoolState (StrictSeq StakePoolRelay) +spsRelaysL = lens spsRelays $ \sps rs -> sps {spsRelays = rs} + +spsMetadataL :: Lens' StakePoolState (StrictMaybe PoolMetadata) +spsMetadataL = lens spsMetadata $ \sps md -> sps {spsMetadata = md} + +spsDepositL :: Lens' StakePoolState (CompactForm Coin) +spsDepositL = lens spsDeposit $ \sps d -> sps {spsDeposit = d} instance EncCBOR StakePoolState where encCBOR sps = @@ -150,6 +178,7 @@ instance EncCBOR StakePoolState where !> To (spsOwners sps) !> To (spsRelays sps) !> To (spsMetadata sps) + !> To (spsDeposit sps) instance DecCBOR StakePoolState where decCBOR = @@ -163,6 +192,7 @@ instance DecCBOR StakePoolState where StakePoolState -mkStakePoolState pp = +mkStakePoolState :: CompactForm Coin -> PoolParams -> StakePoolState +mkStakePoolState deposit pp = StakePoolState { spsVrf = ppVrf pp , spsPledge = ppPledge pp @@ -194,6 +225,7 @@ mkStakePoolState pp = , spsOwners = ppOwners pp , spsRelays = ppRelays pp , spsMetadata = ppMetadata pp + , spsDeposit = deposit } -- | Convert 'StakePoolState' back to 'PoolParams' by providing the pool ID. diff --git a/libs/cardano-ledger-core/test/Test/Cardano/Ledger/State/StakePoolSpec.hs b/libs/cardano-ledger-core/test/Test/Cardano/Ledger/State/StakePoolSpec.hs index f6a20945c6d..b470287a512 100644 --- a/libs/cardano-ledger-core/test/Test/Cardano/Ledger/State/StakePoolSpec.hs +++ b/libs/cardano-ledger-core/test/Test/Cardano/Ledger/State/StakePoolSpec.hs @@ -6,6 +6,7 @@ module Test.Cardano.Ledger.State.StakePoolSpec (spec) where +import Cardano.Ledger.Coin import Cardano.Ledger.State import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Arbitrary () @@ -14,8 +15,8 @@ spec :: Spec spec = do describe "StakePoolState" $ do prop "mkStakePoolState/stakePoolStateToPoolParams round-trip" $ - \(poolParams :: PoolParams) -> + \(poolParams :: PoolParams, deposit :: CompactForm Coin) -> let poolId = ppId poolParams - stakePoolState = mkStakePoolState poolParams + stakePoolState = mkStakePoolState deposit poolParams poolParams' = stakePoolStateToPoolParams poolId stakePoolState in poolParams === poolParams' diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs index 922982259f3..b927707c18f 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs @@ -477,6 +477,7 @@ instance Arbitrary StakePoolState where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary instance Arbitrary PoolMetadata where arbitrary = PoolMetadata <$> arbitrary <*> arbitrary @@ -782,7 +783,7 @@ instance (Era era, Arbitrary (Accounts era)) => Arbitrary (DState era) where arbitrary = DState <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary (PState era) where - arbitrary = PState <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = PState <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary Anchor where arbitrary = Anchor <$> arbitrary <*> arbitrary diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Deleg.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Deleg.hs index bfd964ab239..a19f1c5a29d 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Deleg.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Deleg.hs @@ -73,11 +73,11 @@ dRepMembershipPred dRepsMap dRep = dRepsSet f = Set.fromList [k' | k <- Map.keys dRepsMap, Just k' <- [f k]] -- | The DState needs a witnessed set of delegations to be usefull. Use this Spec to obtain a random one -witnessedKeyHashPoolParamMapSpec :: - Era era => WitUniv era -> Specification (Map (KeyHash StakePool) PoolParams) -witnessedKeyHashPoolParamMapSpec univ = - constrained $ \keyPoolParamMap -> - [witness univ (dom_ keyPoolParamMap), witness univ (rng_ keyPoolParamMap)] +witnessedKeyHashStakePoolMapSpec :: + Era era => WitUniv era -> Specification (Map (KeyHash StakePool) StakePoolState) +witnessedKeyHashStakePoolMapSpec univ = + constrained $ \keyPoolMap -> + [witness univ (dom_ keyPoolMap), witness univ (rng_ keyPoolMap)] conwayAccountsSpec :: Era era => diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Specs.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Specs.hs index d108edc1e80..0c475427026 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Specs.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Specs.hs @@ -371,25 +371,21 @@ pStateSpec :: Term EpochNo -> Specification (PState era) pStateSpec univ currepoch = constrained $ \ [var|pState|] -> - match pState $ \_ [var|stakePoolParams|] [var|futureStakePoolParams|] [var|retiring|] [var|pooldeposits|] -> + match pState $ \_ [var|stakePoolParams|] [var|futureStakePoolParams|] [var|retiring|] -> [ witness univ (dom_ stakePoolParams) , witness univ (rng_ stakePoolParams) , witness univ (dom_ futureStakePoolParams) , witness univ (rng_ futureStakePoolParams) , witness univ (dom_ retiring) - , witness univ (dom_ pooldeposits) , assertExplain (pure "dom of retiring is a subset of dom of stakePoolParams") $ dom_ retiring `subset_` dom_ stakePoolParams - , assertExplain (pure "dom of deposits is dom of stakePoolParams") $ - dom_ pooldeposits ==. dom_ stakePoolParams - , assertExplain (pure "no deposit is 0") $ - not_ $ - lit (CompactCoin 0) `elem_` rng_ pooldeposits + , forAll' (rng_ stakePoolParams) $ \_ _ _ _ _ _ _ _ [var|d|] -> + assertExplain (pure "all deposits are greater then (Coin 0)") $ d >=. lit 0 , assertExplain (pure "dom of stakePoolParams is disjoint from futureStakePoolParams") $ dom_ stakePoolParams `disjoint_` dom_ futureStakePoolParams , assertExplain (pure "retiring after current epoch") $ forAll (rng_ retiring) (\ [var|epoch|] -> currepoch <=. epoch) - , assert $ sizeOf_ (futureStakePoolParams) <=. 4 + , assert $ sizeOf_ futureStakePoolParams <=. 4 , assert $ 3 <=. sizeOf_ stakePoolParams , assert $ sizeOf_ stakePoolParams <=. 8 ] diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Tests.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Tests.hs index b99c5e740ab..79ffb7a41c9 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Tests.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Tests.hs @@ -90,7 +90,7 @@ delegationsSpec :: delegationsSpec = (hasSize (rangeSize 8 12)) poolRegSpec :: - forall era. Era era => WitUniv era -> Specification (Map (KeyHash 'StakePool) PoolParams) + forall era. Era era => WitUniv era -> Specification (Map (KeyHash 'StakePool) StakePoolState) poolRegSpec univ = constrained $ \poolRegMap -> [ witness univ (dom_ poolRegMap) , witness univ (rng_ poolRegMap) @@ -135,7 +135,7 @@ specSuite n = do univ <- genWitUniv @era 200 context <- genCertContext @era univ poolreg <- genFromSpec (poolRegSpec univ) - pure (conwayDStateSpec @era univ context (lit $ mkStakePoolState <$> poolreg)) + pure (conwayDStateSpec @era univ context (lit poolreg)) soundSpecWith @(VState era) (10 * n) $ do univ <- genWitUniv @era 200 diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/WellFormed.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/WellFormed.hs index edba6efc805..08294f183af 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/WellFormed.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/WellFormed.hs @@ -23,7 +23,7 @@ import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) import Cardano.Ledger.Shelley.LedgerState import Constrained.API import Data.Map (Map) -import Test.Cardano.Ledger.Constrained.Conway.Deleg (witnessedKeyHashPoolParamMapSpec) +import Test.Cardano.Ledger.Constrained.Conway.Deleg (witnessedKeyHashStakePoolMapSpec) import Test.Cardano.Ledger.Constrained.Conway.Instances import Test.Cardano.Ledger.Constrained.Conway.LedgerTypes.Specs ( accountStateSpec, @@ -70,8 +70,8 @@ dsX :: forall era. era ~ ConwayEra => Gen (DState era) dsX = do univ <- genWitUniv @era 100 context <- genCertContext @era univ - khppMap <- genFromSpec (witnessedKeyHashPoolParamMapSpec univ) - genFromSpec @(DState era) (conwayDStateSpec univ context (lit $ mkStakePoolState <$> khppMap)) + khppMap <- genFromSpec (witnessedKeyHashStakePoolMapSpec univ) + genFromSpec @(DState era) (conwayDStateSpec univ context (lit khppMap)) conwayDStateGen :: forall era. era ~ ConwayEra => Gen (DState era) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Pool.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Pool.hs index 87c3f7b302e..923b03f83cf 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Pool.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Pool.hs @@ -44,21 +44,18 @@ pStateSpec :: WitUniv era -> Specification (PState era) pStateSpec univ = constrained $ \ps -> - match ps $ \_ stakePoolParams futureStakePoolParams retiring deposits -> - [ witness univ (dom_ stakePoolParams) - , witness univ (rng_ stakePoolParams) - , witness univ (dom_ futureStakePoolParams) - , witness univ (rng_ futureStakePoolParams) + match ps $ \_ stakePools futureStakePools retiring -> + [ witness univ (dom_ stakePools) + , witness univ (rng_ stakePools) + , witness univ (dom_ futureStakePools) + , witness univ (rng_ futureStakePools) , witness univ (dom_ retiring) - , witness univ (dom_ deposits) , assertExplain (pure "dom of retiring is a subset of dom of stakePoolParams") $ - dom_ retiring `subset_` dom_ stakePoolParams - , assertExplain (pure "dom of deposits is dom of stakePoolParams") $ - dom_ deposits ==. dom_ stakePoolParams - , forAll' (rng_ deposits) $ \ [var|dep|] -> - assertExplain (pure "all deposits are greater then (Coin 0)") $ dep >=. lit 0 + dom_ retiring `subset_` dom_ stakePools + , forAll' (rng_ stakePools) $ \_ _ _ _ _ _ _ _ [var|d|] -> + assertExplain (pure "all deposits are greater then (Coin 0)") $ d >=. lit 0 , assertExplain (pure "dom of stakePoolParams is disjoint from futureStakePoolParams") $ - dom_ stakePoolParams `disjoint_` dom_ futureStakePoolParams + dom_ stakePools `disjoint_` dom_ futureStakePools ] poolCertSpec :: diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/AggPropTests.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/AggPropTests.hs index 34278fed345..32a434ae4b2 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/AggPropTests.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/AggPropTests.hs @@ -143,7 +143,7 @@ depositInvariant SourceSignalTarget {source = mockChainSt} = accountsMap = certState ^. certDStateL . accountsL . accountsMapL allDeposits = utxosDeposited utxost keyDeposits = fromCompact $ foldMap (^. depositAccountStateL) accountsMap - poolDeposits = foldMap fromCompact (psDeposits pstate) + poolDeposits = foldMap (fromCompact . spsDeposit) (psStakePools pstate) in counterexample ( ansiDocToString . Pretty.vsep $ [ "Deposit invariant fails:" @@ -151,7 +151,7 @@ depositInvariant SourceSignalTarget {source = mockChainSt} = [ "All deposits = " ++ show allDeposits , "Key deposits = " ++ synopsisCoinMap (Just (Map.map (fromCompact . (^. depositAccountStateL)) accountsMap)) - , "Pool deposits = " ++ synopsisCoinMap (Just (fromCompact <$> psDeposits pstate)) + , "Pool deposits = " ++ synopsisCoinMap (Just (fromCompact . spsDeposit <$> psStakePools pstate)) ] ] ) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs index e39d0cb26bc..083c45d0943 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs @@ -327,7 +327,7 @@ instance EraAccounts era => TotalAda (DState era) where dState ^. accountsL . accountsMapL instance TotalAda (PState era) where - totalAda pstate = Fold.fold (fromCompact <$> psDeposits pstate) + totalAda pstate = Fold.fold (fromCompact . spsDeposit <$> psStakePools pstate) instance TotalAda (VState era) where totalAda _ = mempty diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs index d0156f393dc..2e44fbaf0e6 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs @@ -147,7 +147,6 @@ import Test.Cardano.Ledger.Generic.ModelState ( genDelegsZero, instantaneousRewardsZero, mNewEpochStateZero, - mPoolDeposits, ) import Test.Cardano.Ledger.Generic.Proof hiding (lift) import Test.Cardano.Ledger.Shelley.Era @@ -467,12 +466,12 @@ modifyModelAccounts f = modifyModel (\ms -> ms {mAccounts = f (mAccounts ms)}) modifyModelDeposited :: (Coin -> Coin) -> GenRS era () modifyModelDeposited f = modifyModel (\ms -> ms {mDeposited = f (mDeposited ms)}) -modifyModelPoolParams :: - ( Map.Map (KeyHash 'StakePool) PoolParams -> - Map.Map (KeyHash 'StakePool) PoolParams +modifyModelStakePools :: + ( Map.Map (KeyHash 'StakePool) StakePoolState -> + Map.Map (KeyHash 'StakePool) StakePoolState ) -> GenRS era () -modifyModelPoolParams f = modifyModel (\ms -> ms {mPoolParams = f (mPoolParams ms)}) +modifyModelStakePools f = modifyModel (\ms -> ms {mStakePools = f (mStakePools ms)}) modifyModelPoolDistr :: ( Map (KeyHash 'StakePool) IndividualPoolStake -> @@ -481,10 +480,6 @@ modifyModelPoolDistr :: GenRS era () modifyModelPoolDistr f = modifyModel (\ms -> ms {mPoolDistr = f (mPoolDistr ms)}) -modifyModelKeyDeposits :: KeyHash 'StakePool -> Coin -> GenRS era () -modifyModelKeyDeposits kh pooldeposit = - modifyModel (\ms -> ms {mPoolDeposits = Map.insert kh pooldeposit (mPoolDeposits ms)}) - modifyModelCount :: (Int -> Int) -> GenRS era () modifyModelCount f = modifyModel (\ms -> ms {mCount = f (mCount ms)}) @@ -596,8 +591,8 @@ getUtxoTest = do -- may actually add to the mPoolParams, and then the added thing won't appear new. getNewPoolTest :: GenRS era (KeyHash 'StakePool -> Bool) getNewPoolTest = do - poolparams <- gets (mPoolParams . gsModel) - pure (`Map.member` poolparams) + stakePools <- gets (mStakePools . gsModel) + pure (`Map.member` stakePools) -- ======================================================================== -- Tools to get started in the Monad @@ -673,7 +668,11 @@ initialLedgerState gstate = LedgerState utxostate dpstate genDelegsZero instantaneousRewardsZero pstate = - PState Set.empty (mkStakePoolState <$> pools) Map.empty Map.empty (fmap (const poolDeposit) pools) + PState + Set.empty + (mkStakePoolState poolDeposit <$> pools) + Map.empty + Map.empty -- In a wellformed LedgerState the deposited equals the obligation deposited = totalObligation dpstate (utxostate ^. utxosGovStateL) pools = gsInitialPoolParams gstate @@ -1008,8 +1007,7 @@ initStableFields = do modifyGenStateStablePools (Set.insert kh) modifyGenStateInitialPoolParams (Map.insert kh poolParams) modifyGenStateInitialPoolDistr (Map.insert kh ips) - modifyModelPoolParams (Map.insert kh poolParams) - modifyModelKeyDeposits kh (pp ^. ppPoolDepositL) + modifyModelStakePools (Map.insert kh $ mkStakePoolState (pp ^. ppPoolDepositCompactL) poolParams) return kh -- This incantation gets a list of fresh (not previously generated) Credential @@ -1063,7 +1061,8 @@ genRewards = do genRetirementHash :: forall era. Reflect era => GenRS era (KeyHash 'StakePool) genRetirementHash = do - m <- gets (mPoolParams . gsModel) + m <- gets (mStakePools . gsModel) + pp <- gets (mPParams . gsModel) honestKhs <- gets gsStablePools avoidKey <- gets gsAvoidKey res <- lift . genMapElemWhere m 10 $ \kh _ -> @@ -1081,7 +1080,8 @@ genRetirementHash = do modifyGenStateInitialPoolDistr (Map.insert poolid stake) -- add the Pool to the Model - modifyModelPoolParams (Map.insert poolid poolparams) + modifyModelStakePools + (Map.insert poolid $ mkStakePoolState (pp ^. ppPoolDepositCompactL) poolparams) modifyModelPoolDistr (Map.insert poolid stake) pure poolid @@ -1094,15 +1094,16 @@ genPool = frequencyT [(10, genNew), (90, pickExisting)] where genNew = do (kh, pp, ips) <- genNewPool + pparams <- gets (mPParams . gsModel) -- add pool to initial state modifyGenStateInitialPoolParams (Map.insert kh pp) modifyGenStateInitialPoolDistr (Map.insert kh ips) -- update the model - modifyModelPoolParams (Map.insert kh pp) + modifyModelStakePools (Map.insert kh $ mkStakePoolState (pparams ^. ppPoolDepositCompactL) pp) return (kh, pp) pickExisting = do - psStakePools <- gets (mPoolParams . gsModel) + psStakePools <- gets (mStakePools . gsModel) avoidKey <- gets gsAvoidKey lift (genMapElemWhere psStakePools 10 (\kh _ -> kh `Set.notMember` avoidKey)) >>= \case Nothing -> genNew - Just (kh, pp) -> pure (kh, pp) + Just (kh, pp) -> pure (kh, stakePoolStateToPoolParams kh pp) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Instances.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Instances.hs index 691b52f791d..28a68b17fa8 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Instances.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Instances.hs @@ -115,16 +115,15 @@ applyShelleyCert model dcert = case dcert of } ShelleyTxCertPool (RegPool poolparams) -> model - { mPoolParams = Map.insert hk poolparams (mPoolParams model) + { mStakePools = + Map.insert + hk + (mkStakePoolState (pp ^. ppPoolDepositCompactL) poolparams) + (mStakePools model) , mDeposited = - if Map.member hk (mPoolDeposits model) + if Map.member hk (mStakePools model) then mDeposited model else mDeposited model <+> pp ^. ppPoolDepositL - , mPoolDeposits -- Only add if it i[sn't already there - = - if Map.member hk (mPoolDeposits model) - then mPoolDeposits model - else Map.insert hk (pp ^. ppPoolDepositL) (mPoolDeposits model) } where hk = ppId poolparams diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs index 401a2c086ee..7b5c8f1e48d 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs @@ -37,7 +37,6 @@ module Test.Cardano.Ledger.Generic.ModelState where import Cardano.Ledger.BaseTypes (BlocksMade (..)) import Cardano.Ledger.Coin (Coin (..), CompactForm (CompactCoin)) -import Cardano.Ledger.Compactible (Compactible (..)) import Cardano.Ledger.Conway.State import Cardano.Ledger.Hashes (GenDelegs (..)) import Cardano.Ledger.Shelley.Core @@ -85,8 +84,7 @@ type MUtxo era = Map TxIn (TxOut era) data ModelNewEpochState era = ModelNewEpochState { -- PState fields - mPoolParams :: !(Map (KeyHash 'StakePool) PoolParams) - , mPoolDeposits :: !(Map (KeyHash 'StakePool) Coin) + mStakePools :: !(Map (KeyHash 'StakePool) StakePoolState) , -- DState state fields mAccounts :: !(Accounts era) , -- _fGenDelegs, _genDelegs, and _irwd, are for @@ -112,7 +110,7 @@ data ModelNewEpochState era = ModelNewEpochState , mCount :: !Int , mIndex :: !(Map Int TxId) , -- below here NO EFFECT until we model EpochBoundary - mFPoolParams :: !(Map (KeyHash 'StakePool) PoolParams) + mFStakePools :: !(Map (KeyHash 'StakePool) StakePoolState) , mRetiring :: !(Map (KeyHash 'StakePool) EpochNo) , mSnapshots :: !SnapShots , mEL :: !EpochNo -- The current epoch, @@ -166,7 +164,6 @@ pStateZero = , psStakePools = Map.empty , psFutureStakePools = Map.empty , psRetiring = Map.empty - , psDeposits = Map.empty } dPStateZero :: EraCertState era => CertState era @@ -223,8 +220,7 @@ stashedAVVMAddressesZero Allegra = () mNewEpochStateZero :: (EraPParams era, EraAccounts era) => ModelNewEpochState era mNewEpochStateZero = ModelNewEpochState - { mPoolParams = Map.empty - , mPoolDeposits = Map.empty + { mStakePools = Map.empty , mAccounts = def , mUTxO = Map.empty , mMutFee = Map.empty @@ -236,7 +232,7 @@ mNewEpochStateZero = , mCount = 0 , mIndex = Map.empty , -- below here NO EFFECT until we model EpochBoundary - mFPoolParams = Map.empty + mFStakePools = Map.empty , mRetiring = Map.empty , mSnapshots = emptySnapShots , mEL = EpochNo 0 @@ -268,10 +264,9 @@ instance Extract (PState era) era where extract x = PState Set.empty - (mkStakePoolState <$> mPoolParams x) - (mkStakePoolState <$> mFPoolParams x) + (mStakePools x) + (mFStakePools x) (mRetiring x) - Map.empty instance Extract (VState era) era where extract _ = VState def def (EpochNo 0) @@ -326,16 +321,14 @@ instance forall era. Reflect era => Extract (NewEpochState era) era where abstract :: (EraGov era, EraCertState era) => NewEpochState era -> ModelNewEpochState era abstract x = ModelNewEpochState - { mPoolParams = - ( Map.mapWithKey stakePoolStateToPoolParams - . psStakePools + { mStakePools = + ( psStakePools . certPState . lsCertState . esLState . nesEs ) x - , mPoolDeposits = (fmap fromCompact . psDeposits . certPState . lsCertState . esLState . nesEs) x , mAccounts = (dsAccounts . certDState . lsCertState . esLState . nesEs) x , mUTxO = (unUTxO . utxosUtxo . lsUTxOState . esLState . nesEs) x , mMutFee = Map.empty @@ -347,9 +340,8 @@ abstract x = , mCount = 0 , mIndex = Map.empty , -- below here NO EFFECT until we model EpochBoundary - mFPoolParams = - ( Map.mapWithKey stakePoolStateToPoolParams - . psFutureStakePools + mFStakePools = + ( psFutureStakePools . certPState . lsCertState . esLState diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs index 37b7c8fb3a1..1db8565ab09 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs @@ -210,7 +210,6 @@ raiseMockError :: String raiseMockError slot (SlotNo next) epochstate _pdfs _txs _ = let _ssPoolParams = epochstate ^. esLStateL . lsCertStateL . certPStateL . psStakePoolsL - _pooldeposits = epochstate ^. esLStateL . lsCertStateL . certPStateL . psDepositsL in show [ toExpr $ adaPots reify epochstate , toExpr slot diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs index df2044ea573..79b34f5b746 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs @@ -607,7 +607,7 @@ genTxCerts slot = do RetirePoolTxCert kh _ -> do -- We need to make sure that the pool is registered before -- we try to retire it - modelPools <- gets $ mPoolParams . gsModel + modelPools <- gets $ mStakePools . gsModel case Map.lookup kh modelPools of Just _ -> pure (dc : dcs, ss, regCreds) Nothing -> pure (dcs, ss, regCreds)