From 7e9b2a6d3bf38ebbac8b464e02f2aac7021c385c Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 30 Oct 2025 15:34:35 +0000 Subject: [PATCH 01/13] Add delegators to StakePoolState --- .../src/Cardano/Ledger/Shelley/Rules/Pool.hs | 10 ++++++++-- .../src/Cardano/Ledger/Shelley/Transition.hs | 4 ++-- .../Shelley/UnitTests/InstantStakeTest.hs | 2 +- .../Test/Cardano/Ledger/Shelley/Rules/Pool.hs | 2 +- .../Ledger/Shelley/Examples/Combinators.hs | 6 +++--- libs/cardano-ledger-core/CHANGELOG.md | 2 ++ .../src/Cardano/Ledger/State/StakePool.hs | 17 +++++++++++++++-- .../Test/Cardano/Ledger/State/StakePoolSpec.hs | 18 ++++++++++++------ .../Test/Cardano/Ledger/Core/Arbitrary.hs | 1 + .../Constrained/Conway/LedgerTypes/Specs.hs | 2 +- .../Cardano/Ledger/Constrained/Conway/Pool.hs | 2 +- .../Test/Cardano/Ledger/Generic/GenState.hs | 9 +++++---- .../Test/Cardano/Ledger/Generic/Instances.hs | 2 +- 13 files changed, 53 insertions(+), 24 deletions(-) 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 bc012856ccf..b3813ab8cf7 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -260,7 +260,8 @@ poolDelegationTransition = do tellEvent $ RegisterPool sppId pure $ ps - & psStakePoolsL %~ Map.insert sppId (mkStakePoolState (pp ^. ppPoolDepositCompactL) stakePoolParams) + & psStakePoolsL + %~ Map.insert sppId (mkStakePoolState (pp ^. ppPoolDepositCompactL) mempty stakePoolParams) & psVRFKeyHashesL %~ updateVRFKeyHash -- re-register Pool Just stakePoolState -> do @@ -293,10 +294,15 @@ poolDelegationTransition = do -- 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. + let futureStakePoolState = + mkStakePoolState + (stakePoolState ^. spsDepositL) + (stakePoolState ^. spsDelegatorsL) + stakePoolParams pure $ ps & psFutureStakePoolsL - %~ Map.insert sppId (mkStakePoolState (stakePoolState ^. spsDepositL) stakePoolParams) + %~ Map.insert sppId futureStakePoolState & psRetiringL %~ Map.delete sppId & psVRFKeyHashesL %~ updateFutureVRFKeyHash RetirePool sppId e -> do diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs index 8073abe4258..0c3f946278a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs @@ -395,11 +395,11 @@ registerInitialStakePools :: registerInitialStakePools ShelleyGenesisStaking {sgsPools} nes = nes & nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL - .~ ListMap.toMap (mkStakePoolState deposit <$> sgsPools) + .~ ListMap.toMap (mkStakePoolState deposit mempty <$> sgsPools) where deposit = nes ^. nesEsL . curPParamsEpochStateL . ppPoolDepositCompactL --- | Register all staking credentials and apply delegations. Make sure StakePools that are bing +-- | Register all staking credentials and apply delegations. Make sure StakePools that are being -- delegated to are already registered, which can be done with `registerInitialStakePools`. shelleyRegisterInitialAccounts :: forall era. 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 796b1ef26ee..ee4428a1ed5 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 mempty <$> poolparamMap + pState <- arbitraryLens psStakePoolsL $ mkStakePoolState mempty 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/Pool.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs index e7a66848d9a..6daac34eb55 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 @@ -134,7 +134,7 @@ poolRegistrationProp , counterexample "New StakePoolParams are registered in future Params map" ( Map.lookup hk (psFutureStakePools targetSt) - === Just (mkStakePoolState (sps ^. spsDepositL) stakePoolParams) + === Just (mkStakePoolState (sps ^. spsDepositL) (sps ^. spsDelegatorsL) stakePoolParams) ) , counterexample "StakePoolParams are removed in 'retiring'" 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 4a932f6c61f..546e3201589 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 @@ -260,7 +260,7 @@ regPool pool cs = cs {chainNes = nes'} { psStakePools = Map.insert (sppId pool) - (mkStakePoolState poolDeposit pool) + (mkStakePoolState poolDeposit mempty pool) (psStakePools ps) } Just sps -> @@ -268,7 +268,7 @@ regPool pool cs = cs {chainNes = nes'} { psFutureStakePools = Map.insert (sppId pool) - (mkStakePoolState (spsDeposit sps) pool) + (mkStakePoolState (spsDeposit sps) mempty pool) (psFutureStakePools ps) } dps' = dps & certPStateL .~ ps' @@ -301,7 +301,7 @@ updatePoolParams pool cs = cs {chainNes = nes'} { psStakePools = Map.insert (sppId pool) - (mkStakePoolState (es ^. curPParamsEpochStateL . ppPoolDepositCompactL) pool) + (mkStakePoolState (es ^. curPParamsEpochStateL . ppPoolDepositCompactL) mempty pool) (psStakePools ps) , psFutureStakePools = Map.delete (sppId pool) (psStakePools ps) } diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index dfebe8a26e2..57f6efae26d 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.19.0.0 +* Add `spsDelegators` field to `StakePool` +* Add `spsDelegatorsL` * Add `fromStrictMaybeL`, `toStrictMaybeL` * Add `memoRawTypeL` * Remove `getterMemoRawType` 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 21743ee2fa8..5e1bc4a1a83 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | This module provides the 'StakePoolState' data type, which represents the @@ -36,6 +37,7 @@ module Cardano.Ledger.State.StakePool ( spsOwnersL, spsRelaysL, spsMetadataL, + spsDelegatorsL, spsDepositL, -- * Conversions @@ -99,6 +101,7 @@ import Cardano.Ledger.Binary.Coders ( ( sps {spsMetadata = md} spsDepositL :: Lens' StakePoolState (CompactForm Coin) spsDepositL = lens spsDeposit $ \sps d -> sps {spsDeposit = d} +spsDelegatorsL :: Lens' StakePoolState (Set (Credential 'Staking)) +spsDelegatorsL = lens spsDelegators $ \sps delegators -> sps {spsDelegators = delegators} + instance EncCBOR StakePoolState where encCBOR sps = encode $ @@ -185,6 +193,7 @@ instance EncCBOR StakePoolState where !> To (spsRelays sps) !> To (spsMetadata sps) !> To (spsDeposit sps) + !> To (spsDelegators sps) instance DecCBOR StakePoolState where decCBOR = @@ -199,6 +208,7 @@ instance DecCBOR StakePoolState where StakePoolParams -> StakePoolState -mkStakePoolState deposit spp = +mkStakePoolState :: + CompactForm Coin -> Set (Credential 'Staking) -> StakePoolParams -> StakePoolState +mkStakePoolState deposit delegators spp = StakePoolState { spsVrf = sppVrf spp , spsPledge = sppPledge spp @@ -232,6 +244,7 @@ mkStakePoolState deposit spp = , spsRelays = sppRelays spp , spsMetadata = sppMetadata spp , spsDeposit = deposit + , spsDelegators = delegators } -- | Convert 'StakePoolState' back to 'StakePoolParams' 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 41c391cbdd6..fe9127e896e 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 @@ -7,16 +7,22 @@ module Test.Cardano.Ledger.State.StakePoolSpec (spec) where import Cardano.Ledger.Coin +import Cardano.Ledger.Core +import Cardano.Ledger.Credential (Credential) import Cardano.Ledger.State +import Data.Set (Set) import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Arbitrary () spec :: Spec spec = do describe "StakePoolState" $ do - prop "mkStakePoolState/stakePoolStateToStakePoolParams round-trip" $ - \(stakePoolParams :: StakePoolParams, deposit :: CompactForm Coin) -> - let poolId = sppId stakePoolParams - stakePoolState = mkStakePoolState deposit stakePoolParams - stakePoolParams' = stakePoolStateToStakePoolParams poolId stakePoolState - in stakePoolParams === stakePoolParams' + prop "mkStakePoolState/stakePoolStateToPoolParams round-trip" $ + \( stakePoolParams :: StakePoolParams + , deposit :: CompactForm Coin + , delegs :: Set (Credential 'Staking) + ) -> + let poolId = sppId stakePoolParams + stakePoolState = mkStakePoolState deposit delegs stakePoolParams + stakePoolParams' = stakePoolStateToStakePoolParams poolId stakePoolState + in stakePoolParams === stakePoolParams' 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 357905d5b97..35eff8a189a 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 @@ -462,6 +462,7 @@ instance Arbitrary StakePoolState where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary instance Arbitrary PoolMetadata where arbitrary = PoolMetadata <$> arbitrary <*> arbitrary 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 9866118f187..e71ca6b839a 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 @@ -379,7 +379,7 @@ pStateSpec univ currepoch = constrained $ \ [var|pState|] -> , witness univ (dom_ retiring) , assertExplain (pure "dom of retiring is a subset of dom of stakePoolParams") $ dom_ retiring `subset_` dom_ stakePoolParams - , forAll' (rng_ stakePoolParams) $ \_ _ _ _ _ _ _ _ [var|d|] -> + , 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 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 923b03f83cf..31cdd078b69 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 @@ -52,7 +52,7 @@ pStateSpec univ = constrained $ \ps -> , witness univ (dom_ retiring) , assertExplain (pure "dom of retiring is a subset of dom of stakePoolParams") $ dom_ retiring `subset_` dom_ stakePools - , forAll' (rng_ stakePools) $ \_ _ _ _ _ _ _ _ [var|d|] -> + , 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_ stakePools `disjoint_` dom_ futureStakePools 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 b63885760af..3756606cfe2 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 @@ -670,7 +670,7 @@ initialLedgerState gstate = LedgerState utxostate dpstate pstate = PState Map.empty - (mkStakePoolState poolDeposit <$> pools) + (mkStakePoolState poolDeposit mempty <$> pools) Map.empty Map.empty -- In a wellformed LedgerState the deposited equals the obligation @@ -1008,7 +1008,7 @@ initStableFields = do modifyGenStateInitialStakePoolParams (Map.insert kh stakePoolParams) modifyGenStateInitialPoolDistr (Map.insert kh ips) modifyModelStakePools - (Map.insert kh $ mkStakePoolState (pp ^. ppPoolDepositCompactL) stakePoolParams) + (Map.insert kh $ mkStakePoolState (pp ^. ppPoolDepositCompactL) mempty stakePoolParams) return kh -- This incantation gets a list of fresh (not previously generated) Credential @@ -1082,7 +1082,7 @@ genRetirementHash = do -- add the Pool to the Model modifyModelStakePools - (Map.insert poolid $ mkStakePoolState (pp ^. ppPoolDepositCompactL) poolparams) + (Map.insert poolid $ mkStakePoolState (pp ^. ppPoolDepositCompactL) mempty poolparams) modifyModelPoolDistr (Map.insert poolid stake) pure poolid @@ -1100,7 +1100,8 @@ genPool = frequencyT [(10, genNew), (90, pickExisting)] modifyGenStateInitialStakePoolParams (Map.insert kh spp) modifyGenStateInitialPoolDistr (Map.insert kh ips) -- update the model - modifyModelStakePools (Map.insert kh $ mkStakePoolState (pparams ^. ppPoolDepositCompactL) spp) + modifyModelStakePools + (Map.insert kh $ mkStakePoolState (pparams ^. ppPoolDepositCompactL) mempty spp) return (kh, spp) pickExisting = do psStakePools <- gets (mStakePools . gsModel) 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 2aca2a3ba5a..dfe5720cfc3 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 @@ -118,7 +118,7 @@ applyShelleyCert model dcert = case dcert of { mStakePools = Map.insert hk - (mkStakePoolState (pp ^. ppPoolDepositCompactL) stakePoolParams) + (mkStakePoolState (pp ^. ppPoolDepositCompactL) mempty stakePoolParams) (mStakePools model) , mDeposited = if Map.member hk (mStakePools model) From d67eaa58746efa7ddab8f5344ee89f41b1f30410 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 30 Sep 2025 18:32:10 +0100 Subject: [PATCH 02/13] Update `StakePoolState` delegs when (re)delegating stake in conway --- .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs index 76d17a608ff..8115af7fd93 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -312,6 +312,7 @@ processDelegationInternal preserveIncorrectDelegation stakeCred mCurDelegatee ne cState & certDStateL . accountsL %~ adjustAccountState (stakePoolDelegationAccountStateL ?~ stakePool) stakeCred + & certPStateL %~ adjustPState stakePool delegVote dRep cState = let cState' = processDRepUnDelegation stakeCred mCurDelegatee cState @@ -326,6 +327,26 @@ processDelegationInternal preserveIncorrectDelegation stakeCred mCurDelegatee ne let dRepState' = dRepState {drepDelegs = Set.insert stakeCred (drepDelegs dRepState)} in cState' & certVStateL . vsDRepsL .~ Map.insert targetDRep dRepState' dReps _ -> cState' + adjustPState newPool = + (psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.insert stakeCred) newPool) + . unDelegStakePool stakeCred mCurDelegatee newPool + +unDelegStakePool :: + Credential 'Staking -> + Maybe Delegatee -> + KeyHash 'StakePool -> + PState era -> + PState era +unDelegStakePool stakeCred mCurDelegatee newPool = + maybe + id + (\oldPool -> psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.delete stakeCred) oldPool) + (mCurDelegatee >>= stakePoolToUnDeleg) + where + stakePoolToUnDeleg = \case + DelegStake oldPool | oldPool /= newPool -> Just oldPool + DelegStakeVote oldPool _ | oldPool /= newPool -> Just oldPool + _ -> Nothing processDRepUnDelegation :: ConwayEraCertState era => From 85716840f278a39a96173ffd655cca45e7e45dd2 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 1 Oct 2025 11:12:56 +0100 Subject: [PATCH 03/13] Refactor `processDRepUndelgation` for consistency --- .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 48 +++++++++---------- 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs index 8115af7fd93..8633a33042e 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -54,6 +54,7 @@ import Cardano.Ledger.Conway.TxCert ( Delegatee (DelegStake, DelegStakeVote, DelegVote), ) import Cardano.Ledger.Credential (Credential) +import Cardano.Ledger.DRep import Control.DeepSeq (NFData) import Control.Monad (forM_, guard, unless) import Control.State.Transition ( @@ -255,8 +256,10 @@ conwayDelegTransition = do isJust mAccountState ?! StakeKeyNotRegisteredDELEG stakeCred failOnJust checkStakeKeyHasZeroRewardBalance StakeKeyHasNonZeroRewardAccountBalanceDELEG pure $ - processDRepUnDelegation stakeCred mCurDelegatee $ - certState & certDStateL . accountsL .~ newAccounts + certState + & certDStateL . accountsL .~ newAccounts + & certVStateL %~ unDelegDRep stakeCred mCurDelegatee + & certPStateL %~ unDelegStakePool stakeCred mCurDelegatee Nothing ConwayDelegCert stakeCred delegatee -> do mCurDelegatee <- checkStakeKeyIsRegistered stakeCred checkStakeDelegateeRegistered delegatee @@ -315,9 +318,10 @@ processDelegationInternal preserveIncorrectDelegation stakeCred mCurDelegatee ne & certPStateL %~ adjustPState stakePool delegVote dRep cState = let cState' = - processDRepUnDelegation stakeCred mCurDelegatee cState + cState & certDStateL . accountsL %~ adjustAccountState (dRepDelegationAccountStateL ?~ dRep) stakeCred + & certVStateL %~ unDelegDRep stakeCred mCurDelegatee dReps | preserveIncorrectDelegation = cState ^. certVStateL . vsDRepsL | otherwise = cState' ^. certVStateL . vsDRepsL @@ -329,41 +333,37 @@ processDelegationInternal preserveIncorrectDelegation stakeCred mCurDelegatee ne _ -> cState' adjustPState newPool = (psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.insert stakeCred) newPool) - . unDelegStakePool stakeCred mCurDelegatee newPool + . unDelegStakePool stakeCred mCurDelegatee (Just newPool) unDelegStakePool :: Credential 'Staking -> Maybe Delegatee -> - KeyHash 'StakePool -> + Maybe (KeyHash 'StakePool) -> PState era -> PState era -unDelegStakePool stakeCred mCurDelegatee newPool = +unDelegStakePool stakeCred mCurDelegatee mNewPool = maybe id (\oldPool -> psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.delete stakeCred) oldPool) (mCurDelegatee >>= stakePoolToUnDeleg) where stakePoolToUnDeleg = \case - DelegStake oldPool | oldPool /= newPool -> Just oldPool - DelegStakeVote oldPool _ | oldPool /= newPool -> Just oldPool + DelegStake oldPool | Just oldPool /= mNewPool -> Just oldPool + DelegStakeVote oldPool _ | Just oldPool /= mNewPool -> Just oldPool _ -> Nothing -processDRepUnDelegation :: - ConwayEraCertState era => +unDelegDRep :: Credential 'Staking -> Maybe Delegatee -> - CertState era -> - CertState era -processDRepUnDelegation _ Nothing cState = cState -processDRepUnDelegation stakeCred (Just delegatee) cState = - case delegatee of - DelegStake _ -> cState - DelegVote dRep -> cState & certVStateL .~ unDelegVote (cState ^. certVStateL) dRep - DelegStakeVote _sPool dRep -> cState & certVStateL .~ unDelegVote (cState ^. certVStateL) dRep + VState era -> + VState era +unDelegDRep stakeCred mCurDelegatee = + maybe + id + (\dRepCred -> vsDRepsL %~ Map.adjust (drepDelegsL %~ Set.delete stakeCred) dRepCred) + (mCurDelegatee >>= drepToUndeleg) where - unDelegVote vState = \case - DRepCredential dRepCred -> - let removeDelegation dRepState = - dRepState {drepDelegs = Set.delete stakeCred (drepDelegs dRepState)} - in vState & vsDRepsL %~ Map.adjust removeDelegation dRepCred - _ -> vState + drepToUndeleg = \case + DelegVote (DRepCredential dRepCred) -> Just dRepCred + DelegStakeVote _ (DRepCredential dRepCred) -> Just dRepCred + _ -> Nothing From 9b0c43596d4d4efcb08bb82d40362daaab1702a1 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 30 Oct 2025 16:12:42 +0000 Subject: [PATCH 04/13] Use StakePoolState delegs to remove delegations when retiring pools --- .../Cardano/Ledger/Shelley/Rules/PoolReap.hs | 9 ++++-- .../Ledger/Shelley/Examples/Combinators.hs | 6 ++-- libs/cardano-ledger-core/CHANGELOG.md | 1 + .../src/Cardano/Ledger/State/Account.hs | 28 ++++++++----------- 4 files changed, 24 insertions(+), 20 deletions(-) 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 69b76676b96..7b8173e496d 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs @@ -208,11 +208,12 @@ poolReapTransition = do a {casTreasury = casTreasury a <+> fromCompact unclaimed} ( cs & certDStateL . accountsL - %~ removeStakePoolDelegations retired . addToBalanceAccounts refunds + %~ removeStakePoolDelegations (delegsToClear cs retired) + . addToBalanceAccounts refunds & certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retired) & certPStateL . psRetiringL %~ (`Map.withoutKeys` retired) & certPStateL . psVRFKeyHashesL - %~ ( removeVRFKeyHashOccurrences (retiredVRFKeyHashes) + %~ ( removeVRFKeyHashOccurrences retiredVRFKeyHashes . (`Map.withoutKeys` danglingVRFKeyHashes) ) ) @@ -226,6 +227,10 @@ poolReapTransition = do -- Removes the key from the map if the value drops to 0 Map.update (mapNonZero (\n -> n - 1)) + delegsToClear cState pools = + foldMap spsDelegators $ + Map.restrictKeys (cState ^. certPStateL . psStakePoolsL) pools + renderPoolReapViolation :: ( EraGov era , State t ~ ShelleyPoolreapState era 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 546e3201589..68feb065e11 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 @@ -95,7 +95,6 @@ import Data.Foldable (fold) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) -import qualified Data.Set as Set import Data.Word (Word64) import GHC.Stack (HasCallStack) import Lens.Micro @@ -369,7 +368,10 @@ reapPool pool cs = cs {chainNes = nes'} in ( accounts & accountsMapL %~ Map.insert poolAccountCred accountState' , mempty ) - ds' = ds {dsAccounts = removeStakePoolDelegations (Set.singleton poolId) accounts'} + delegsToClear = + foldMap spsDelegators $ + Map.lookup poolId (dps ^. certPStateL . psStakePoolsL) + ds' = ds {dsAccounts = removeStakePoolDelegations delegsToClear accounts'} chainAccountState = esChainAccountState es chainAccountState' = chainAccountState {casTreasury = casTreasury chainAccountState <+> fromCompact unclaimed} utxoSt = lsUTxOState ls diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 57f6efae26d..821a57267ef 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -4,6 +4,7 @@ * Add `spsDelegators` field to `StakePool` * Add `spsDelegatorsL` +* Change parameter type of `removeStakePoolDelegations` from `Set (KeyHash 'StakePool)` to `Set (Credential 'Staking)` * Add `fromStrictMaybeL`, `toStrictMaybeL` * Add `memoRawTypeL` * Remove `getterMemoRawType` diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/State/Account.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/State/Account.hs index e5a075f67e6..5824cbdb6c8 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/Account.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/Account.hs @@ -45,7 +45,6 @@ import qualified Data.Map.Merge.Strict as Map import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) -import qualified Data.Set as Set import Lens.Micro import NoThunks.Class (NoThunks) @@ -164,7 +163,7 @@ isAccountRegistered cred accounts = Map.member cred (accounts ^. accountsMapL) adjustAccountState :: EraAccounts era => (AccountState era -> AccountState era) -> Credential 'Staking -> Accounts era -> Accounts era -adjustAccountState cred f = accountsMapL %~ Map.adjust cred f +adjustAccountState f cred = accountsMapL %~ Map.adjust f cred -- | In case when account state is registered and it is delegated to a stake pool this function -- will return that delegation. @@ -238,18 +237,15 @@ drainAccounts (Withdrawals withdrawalsMap) accounts = accountsMap withdrawalsMap --- TODO: This is an expensive operation, since it iterates over the whole accountsMap. We need to --- start keeping track of all delegations to the stake pool in its state, then we would be able to --- switch from `Set (KeyHash 'StakePool)` to `Map (KeyHash 'StakePool) (Set (Credential Staking))` --- and drastically speed up this operation. - --- | Remove delegations for the supplied Stake +-- | Remove delegations of supplied credentials removeStakePoolDelegations :: - EraAccounts era => Set (KeyHash 'StakePool) -> Accounts era -> Accounts era -removeStakePoolDelegations stakeDelegationsToRemove accounts = - accounts & accountsMapL %~ Map.map clearAccountStateDelegation - where - clearAccountStateDelegation = - stakePoolDelegationAccountStateL %~ \case - Just poolId | poolId `Set.member` stakeDelegationsToRemove -> Nothing - delegation -> delegation + EraAccounts era => Set (Credential 'Staking) -> Accounts era -> Accounts era +removeStakePoolDelegations creds accounts = + accounts + & accountsMapL + %~ ( \accountsMap -> + foldr + (Map.adjust (stakePoolDelegationAccountStateL .~ Nothing)) + accountsMap + creds + ) From b811e853f2d147b297d9e290f3814ab047718c45 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 7 Oct 2025 16:23:51 +0100 Subject: [PATCH 05/13] Update checks in `DelegSpec` to include delegs in `StakePoolState` and add a test case for redelegating drep --- .../Cardano/Ledger/Conway/Imp/DelegSpec.hs | 47 ++++++++++++++++--- .../Cardano/Ledger/Shelley/Imp/DelegSpec.hs | 7 ++- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 42 +++++++++++++++-- 3 files changed, 84 insertions(+), 12 deletions(-) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs index 475701fde6f..8e48be66e01 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs @@ -182,7 +182,7 @@ spec = do .~ [DelegTxCert cred (DelegStake poolKh)] ) [injectFailure $ DelegateeStakePoolNotRegisteredDELEG poolKh] - expectNotDelegatedToPool cred + expectNotDelegatedToAnyPool cred describe "Delegate vote" $ do it "Delegate vote of registered stake credentials to registered drep" $ do @@ -201,7 +201,7 @@ spec = do .~ [DelegTxCert cred (DelegVote (DRepCredential drepCred))] expectDelegatedVote cred (DRepCredential drepCred) - expectNotDelegatedToPool cred + expectNotDelegatedToAnyPool cred whenBootstrap $ do impAnn "Ensure DRep delegation is populated after bootstrap" $ do -- Clear out delegation, in order to check its repopulation from accounts. @@ -221,6 +221,25 @@ spec = do getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gai) expectDelegatedVote cred (DRepCredential drepCred) + it "Redelegate vote to the same DRep" $ do + expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL + + cred <- KeyHashObj <$> freshKeyHash + drepCred <- KeyHashObj <$> registerDRep + + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL + .~ [RegDepositDelegTxCert cred (DelegVote (DRepCredential drepCred)) expectedDeposit] + expectDelegatedVote cred (DRepCredential drepCred) + + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL + .~ [DelegTxCert cred (DelegVote (DRepCredential drepCred))] + + expectDelegatedVote cred (DRepCredential drepCred) + it "Delegate vote of registered stake credentials to unregistered drep" $ do RewardAccount _ cred <- registerRewardAccount drepCred <- KeyHashObj <$> freshKeyHash @@ -282,7 +301,16 @@ spec = do impAnn "Check that unregistration of previous delegation does not affect current delegation" $ do unRegisterDRep drepCred -- we need to preserve the buggy behavior until the boostrap phase is over. - ifBootstrap (expectNotDelegatedVote cred) (expectDelegatedVote cred (DRepCredential drepCred2)) + ifBootstrap + ( do + -- we cannot `expectNotDelegatedVote` because the delegation is still in the DRepState of the other pool + accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL + expectNothingExpr (lookupDRepDelegation cred accounts) + dReps <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL + drepState2 <- expectJust $ Map.lookup drepCred2 dReps + drepDelegs drepState2 `shouldSatisfy` Set.member cred + ) + (expectDelegatedVote cred (DRepCredential drepCred2)) it "Delegate vote and unregister stake credentials" $ do expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL @@ -298,6 +326,8 @@ spec = do .~ [UnRegDepositTxCert cred expectedDeposit] expectStakeCredNotRegistered cred expectNotDelegatedVote cred + expectNotDelegatedToAnyPool cred + -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/917 -- TODO: Re-enable after issue is resolved, by removing this override disableInConformanceIt "Delegate vote and unregister after hardfork" $ do @@ -410,9 +440,9 @@ spec = do -- when pool is re-registered after its expiration, all delegations are cleared passNEpochs $ fromIntegral poolLifetime - expectNotDelegatedToPool cred + expectNotDelegatedToAnyPool cred registerPoolWithRewardAccount poolKh rewardAccount - expectNotDelegatedToPool cred + expectNotDelegatedToAnyPool cred -- the vote delegation is kept expectDelegatedVote cred (DRepCredential drepCred) @@ -500,6 +530,7 @@ spec = do & bodyTxL . certsTxBodyL .~ [DelegTxCert cred (DelegStake poolKh')] expectDelegatedToPool cred poolKh' + expectNotDelegatedToPool cred poolKh expectDelegatedVote cred (DRepCredential drepCred) where expectDelegatedVote :: HasCallStack => Credential 'Staking -> DRep -> ImpTestM era () @@ -525,5 +556,9 @@ spec = do expectNotDelegatedVote :: Credential 'Staking -> ImpTestM era () expectNotDelegatedVote cred = do accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL - impAnn (show cred <> " expected to not have their vote delegated") $ + dreps <- getsNES $ nesEsL . epochStateRegDrepL + impAnn (show cred <> " expected to not have their vote delegated") $ do expectNothingExpr (lookupDRepDelegation cred accounts) + assertBool + ("Expected no drep state delegation to contain the stake credential: " <> show cred) + (all (Set.notMember cred . drepDelegs) dreps) diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/DelegSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/DelegSpec.hs index 7d37a340c9a..564f76958ab 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/DelegSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/DelegSpec.hs @@ -54,7 +54,7 @@ shelleyEraSpecificSpec = do & bodyTxL . certsTxBodyL .~ [delegStakeTxCert cred poolKh] ) [injectFailure $ DelegateeNotRegisteredDELEG poolKh] - expectNotDelegatedToPool cred + expectNotDelegatedToAnyPool cred it "Deregistering returns the deposit" $ do let keyDeposit = Coin 2 @@ -228,6 +228,7 @@ spec = do else StakeKeyNotRegisteredDELEG cred ] expectStakeCredNotRegistered cred + expectNotDelegatedToAnyPool cred it "Delegate already delegated credentials" $ do cred <- KeyHashObj <$> freshKeyHash @@ -251,6 +252,7 @@ spec = do & bodyTxL . certsTxBodyL .~ [delegStakeTxCert cred poolKh1] expectDelegatedToPool cred poolKh1 + expectNotDelegatedToPool cred poolKh poolKh2 <- freshKeyHash registerPool poolKh2 @@ -265,6 +267,8 @@ spec = do ] expectDelegatedToPool cred poolKh3 + expectNotDelegatedToPool cred poolKh2 + expectNotDelegatedToPool cred poolKh it "Delegate and unregister" $ do cred <- KeyHashObj <$> freshKeyHash @@ -277,3 +281,4 @@ spec = do & bodyTxL . certsTxBodyL .~ [regTxCert, delegStakeTxCert cred poolKh, unRegTxCert] expectStakeCredNotRegistered cred + expectNotDelegatedToAnyPool cred diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index dfb0c840828..bbe182216e2 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -71,6 +71,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( delegateStake, registerRewardAccount, registerStakeCredential, + expectNotDelegatedToAnyPool, expectNotDelegatedToPool, expectStakeCredRegistered, expectStakeCredNotRegistered, @@ -1637,20 +1638,51 @@ expectDelegatedToPool :: KeyHash 'StakePool -> ImpTestM era () expectDelegatedToPool cred poolKh = do - accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL + certState <- getsNES $ nesEsL . esLStateL . lsCertStateL + let accounts = certState ^. certDStateL . accountsL + let pools = certState ^. certPStateL . psStakePoolsL impAnn (show cred <> " expected to have delegated to " <> show poolKh) $ do accountState <- expectJust $ lookupAccountState cred accounts accountState ^. stakePoolDelegationAccountStateL `shouldBe` Just poolKh + case Map.lookup poolKh pools of + Nothing -> + assertFailure $ + "Expected stake pool state for: " <> show poolKh + Just poolState -> + assertBool + ("Expected pool delegations to contain the stake credential: " <> show cred) + (cred `Set.member` (poolState ^. spsDelegatorsL)) + +expectNotDelegatedToAnyPool :: + (HasCallStack, ShelleyEraImp era) => + Credential 'Staking -> + ImpTestM era () +expectNotDelegatedToAnyPool cred = do + certState <- getsNES $ nesEsL . esLStateL . lsCertStateL + let accounts = certState ^. certDStateL . accountsL + let pools = certState ^. certPStateL . psStakePoolsL + impAnn (show cred <> " expected to not have delegated to a stake pool") $ do + forM_ (lookupAccountState cred accounts) $ \accountState -> + expectNothingExpr (accountState ^. stakePoolDelegationAccountStateL) + assertBool + ("Expected no stake pool state delegation to contain the stake credential: " <> show cred) + (all (Set.notMember cred . spsDelegators) pools) expectNotDelegatedToPool :: (HasCallStack, ShelleyEraImp era) => Credential 'Staking -> + KeyHash 'StakePool -> ImpTestM era () -expectNotDelegatedToPool cred = do - accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL +expectNotDelegatedToPool cred pool = do + certState <- getsNES $ nesEsL . esLStateL . lsCertStateL + let accounts = certState ^. certDStateL . accountsL + let pools = certState ^. certPStateL . psStakePoolsL impAnn (show cred <> " expected to not have delegated to a stake pool") $ do - accountState <- expectJust $ lookupAccountState cred accounts - expectNothingExpr (accountState ^. stakePoolDelegationAccountStateL) + forM_ (lookupAccountState cred accounts) $ \accountState -> + accountState ^. stakePoolDelegationAccountStateL `shouldNotBe` Just pool + assertBool + ("Expected stake pool state delegation to not contain the stake credential: " <> show cred) + (maybe True (Set.notMember cred . spsDelegators) (Map.lookup pool pools)) registerRewardAccount :: forall era. From fb9299525471738e2562456b746a0c40a6b30d0c Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 8 Oct 2025 13:52:10 +0100 Subject: [PATCH 06/13] Change state of shelley `DelegRule` to `CertState` --- eras/shelley/impl/CHANGELOG.md | 2 + .../src/Cardano/Ledger/Shelley/Rules/Deleg.hs | 83 ++++++++++--------- .../src/Cardano/Ledger/Shelley/Rules/Delpl.hs | 23 ++--- .../Cardano/Ledger/Shelley/Rules/Deleg.hs | 46 +++++----- .../Cardano/Ledger/Shelley/Rules/TestChain.hs | 4 +- .../Ledger/Shelley/Examples/MirTransfer.hs | 26 +++--- libs/cardano-ledger-core/CHANGELOG.md | 1 + .../src/Cardano/Ledger/State/CertState.hs | 18 +++- 8 files changed, 111 insertions(+), 92 deletions(-) diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index cb7f3d4a150..7f6227ae75a 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.18.0.0 +* Change state of `ShelleyDELEG` rule from `DState` to `CertState` +* Add `EraCertState` constraint to `STS` instance for `ShelleyDELEG` * Add `TxLevel` argument to `Tx` and `TxBody` * Add `HasEraTxLevel` instances for `Tx` and `TxBody` * Add `EraTxLevel` instance diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs index 6933ac09a92..555749b3a33 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs @@ -131,10 +131,15 @@ newtype ShelleyDelegEvent era = DelegNewEpoch EpochNo instance NFData (ShelleyDelegEvent era) instance - (EraPParams era, ShelleyEraAccounts era, ShelleyEraTxCert era, AtMostEra "Babbage" era) => + ( EraCertState era + , EraPParams era + , ShelleyEraAccounts era + , ShelleyEraTxCert era + , AtMostEra "Babbage" era + ) => STS (ShelleyDELEG era) where - type State (ShelleyDELEG era) = DState era + type State (ShelleyDELEG era) = CertState era type Signal (ShelleyDELEG era) = TxCert era type Environment (ShelleyDELEG era) = DelegEnv era type BaseM (ShelleyDELEG era) = ShelleyBase @@ -242,17 +247,23 @@ instance k -> invalidKey k delegationTransition :: - (ShelleyEraAccounts era, ShelleyEraTxCert era, EraPParams era, AtMostEra "Babbage" era) => + ( EraCertState era + , ShelleyEraAccounts era + , ShelleyEraTxCert era + , EraPParams era + , AtMostEra "Babbage" era + ) => TransitionRule (ShelleyDELEG era) delegationTransition = do - TRC (DelegEnv slot epochNo ptr chainAccountState pp, ds, c) <- judgmentContext + TRC (DelegEnv slot epochNo ptr chainAccountState pp, certState, c) <- judgmentContext let pv = pp ^. ppProtocolVersionL + ds = certState ^. certDStateL case c of RegTxCert cred -> do -- (hk ∉ dom (rewards ds)) not (isAccountRegistered cred (ds ^. accountsL)) ?! StakeKeyAlreadyRegisteredDELEG cred let compactDeposit = compactCoinOrError (pp ^. ppKeyDepositL) - pure (ds & accountsL %~ registerShelleyAccount cred ptr compactDeposit Nothing) + pure $ certState & certDStateL . accountsL %~ registerShelleyAccount cred ptr compactDeposit Nothing UnRegTxCert cred -> do let !(mAccountState, !accounts) = unregisterShelleyAccount cred (ds ^. accountsL) checkStakeKeyHasZeroRewardBalance = do @@ -263,13 +274,14 @@ delegationTransition = do -- (hk ∈ dom (rewards ds)) isJust mAccountState ?! StakeKeyNotRegisteredDELEG cred failOnJust checkStakeKeyHasZeroRewardBalance StakeKeyNonZeroAccountBalanceDELEG - pure $ ds & accountsL .~ accounts + pure $ certState & certDStateL . accountsL .~ accounts DelegStakeTxCert cred stakePool -> do -- note that pattern match is used instead of cwitness and dpool, as in the spec -- (hk ∈ dom (rewards ds)) isAccountRegistered cred (ds ^. accountsL) ?! StakeDelegationImpossibleDELEG cred pure $ - ds & accountsL %~ adjustAccountState (stakePoolDelegationAccountStateL ?~ stakePool) cred + certState + & certDStateL . accountsL %~ adjustAccountState (stakePoolDelegationAccountStateL ?~ stakePool) cred GenesisDelegTxCert gkh vkh vrf -> do sp <- liftSTS $ asks stabilityWindow -- note that pattern match is used instead of genesisDeleg, as in the spec @@ -294,13 +306,12 @@ delegationTransition = do ?! DuplicateGenesisVRFDELEG vrf pure $ - ds - { dsFutureGenDelegs = - eval (dsFutureGenDelegs ds ⨃ singleton (FutureGenDeleg s' gkh) (GenDelegPair vkh vrf)) - } + certState + & certDStateL . dsFutureGenDelegsL + .~ eval (dsFutureGenDelegs ds ⨃ singleton (FutureGenDeleg s' gkh) (GenDelegPair vkh vrf)) RegPoolTxCert _ -> do failBecause WrongCertificateTypeDELEG -- this always fails - pure ds + pure certState _ | Just (MIRCert targetPot mirTarget) <- getMirTxCert c -> do checkSlotNotTooLate slot epochNo case mirTarget of @@ -327,46 +338,39 @@ delegationTransition = do else do all (>= mempty) credCoinMap ?! MIRNegativesNotCurrentlyAllowed pure (Map.union credCoinMap' instantaneousRewards, potAmount) - updateReservesAndTreasury targetPot combinedMap available ds + updateReservesAndTreasury targetPot combinedMap available certState SendToOppositePotMIR coin -> if hardforkAlonzoAllowMIRTransfer pv then do let available = availableAfterMIR targetPot chainAccountState (dsIRewards ds) coin >= mempty ?! MIRNegativeTransfer targetPot coin coin <= available ?! InsufficientForTransferDELEG targetPot (Mismatch coin available) - - let ir = dsIRewards ds - dr = deltaReserves ir - dt = deltaTreasury ir case targetPot of ReservesMIR -> pure $ - ds - { dsIRewards = - ir - { deltaReserves = dr <> invert (toDeltaCoin coin) - , deltaTreasury = dt <> toDeltaCoin coin - } - } + certState + & certDStateL . dsIRewardsL . iRDeltaReservesL <>~ invert (toDeltaCoin coin) + & certDStateL . dsIRewardsL . iRDeltaTreasuryL <>~ toDeltaCoin coin TreasuryMIR -> pure $ - ds - { dsIRewards = - ir - { deltaReserves = dr <> toDeltaCoin coin - , deltaTreasury = dt <> invert (toDeltaCoin coin) - } - } + certState + & certDStateL . dsIRewardsL . iRDeltaReservesL <>~ toDeltaCoin coin + & certDStateL . dsIRewardsL . iRDeltaTreasuryL <>~ invert (toDeltaCoin coin) else do failBecause MIRTransferNotCurrentlyAllowed - pure ds + pure certState _ -> do -- The impossible case failBecause WrongCertificateTypeDELEG -- this always fails - pure ds + pure certState checkSlotNotTooLate :: - (ShelleyEraAccounts era, ShelleyEraTxCert era, EraPParams era, AtMostEra "Babbage" era) => + ( EraCertState era + , ShelleyEraAccounts era + , ShelleyEraTxCert era + , EraPParams era + , AtMostEra "Babbage" era + ) => SlotNo -> EpochNo -> Rule (ShelleyDELEG era) 'Transition () @@ -380,12 +384,13 @@ checkSlotNotTooLate slot curEpochNo = do slot < tooLate ?! MIRCertificateTooLateinEpochDELEG (Mismatch slot tooLate) updateReservesAndTreasury :: + EraCertState era => MIRPot -> Map.Map (Credential 'Staking) Coin -> Coin -> - DState era -> - Rule (ShelleyDELEG era) 'Transition (DState era) -updateReservesAndTreasury targetPot combinedMap available ds = do + CertState era -> + Rule (ShelleyDELEG era) 'Transition (CertState era) +updateReservesAndTreasury targetPot combinedMap available certState = do let requiredForRewards = fold combinedMap requiredForRewards <= available @@ -397,5 +402,5 @@ updateReservesAndTreasury targetPot combinedMap available ds = do } pure $ case targetPot of - ReservesMIR -> ds {dsIRewards = (dsIRewards ds) {iRReserves = combinedMap}} - TreasuryMIR -> ds {dsIRewards = (dsIRewards ds) {iRTreasury = combinedMap}} + ReservesMIR -> certState & certDStateL . dsIRewardsL . iRReservesL .~ combinedMap + TreasuryMIR -> certState & certDStateL . dsIRewardsL . iRTreasuryL .~ combinedMap diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delpl.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delpl.hs index 084b9363d7e..070e5716889 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delpl.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delpl.hs @@ -120,7 +120,7 @@ instance , EraCertState era , Embed (EraRule "DELEG" era) (ShelleyDELPL era) , Environment (EraRule "DELEG" era) ~ DelegEnv era - , State (EraRule "DELEG" era) ~ DState era + , State (EraRule "DELEG" era) ~ CertState era , Embed (EraRule "POOL" era) (ShelleyDELPL era) , Environment (EraRule "POOL" era) ~ PoolEnv era , State (EraRule "POOL" era) ~ PState era @@ -183,7 +183,7 @@ delplTransition :: forall era. ( Embed (EraRule "DELEG" era) (ShelleyDELPL era) , Environment (EraRule "DELEG" era) ~ DelegEnv era - , State (EraRule "DELEG" era) ~ DState era + , State (EraRule "DELEG" era) ~ CertState era , State (EraRule "POOL" era) ~ PState era , Signal (EraRule "DELEG" era) ~ TxCert era , Embed (EraRule "POOL" era) (ShelleyDELPL era) @@ -201,20 +201,14 @@ delplTransition = do trans @(EraRule "POOL" era) $ TRC (PoolEnv eNo pp, d ^. certPStateL, poolCert) pure $ d & certPStateL .~ ps ShelleyTxCertGenesisDeleg GenesisDelegCert {} -> do - ds <- - trans @(EraRule "DELEG" era) $ - TRC (DelegEnv slot eNo ptr chainAccountState pp, d ^. certDStateL, c) - pure $ d & certDStateL .~ ds + trans @(EraRule "DELEG" era) $ + TRC (DelegEnv slot eNo ptr chainAccountState pp, d, c) ShelleyTxCertDelegCert _ -> do - ds <- - trans @(EraRule "DELEG" era) $ - TRC (DelegEnv slot eNo ptr chainAccountState pp, d ^. certDStateL, c) - pure $ d & certDStateL .~ ds + trans @(EraRule "DELEG" era) $ + TRC (DelegEnv slot eNo ptr chainAccountState pp, d, c) ShelleyTxCertMir _ -> do - ds <- - trans @(EraRule "DELEG" era) $ - TRC (DelegEnv slot eNo ptr chainAccountState pp, d ^. certDStateL, c) - pure $ d & certDStateL .~ ds + trans @(EraRule "DELEG" era) $ + TRC (DelegEnv slot eNo ptr chainAccountState pp, d, c) instance ( Era era @@ -230,6 +224,7 @@ instance instance ( ShelleyEraAccounts era , ShelleyEraTxCert era + , EraCertState era , EraPParams era , AtMostEra "Babbage" era , PredicateFailure (EraRule "DELEG" era) ~ ShelleyDelegPredFailure era diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deleg.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deleg.hs index 4feddbaac07..8ebfd2f9d81 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deleg.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deleg.hs @@ -89,7 +89,7 @@ tests = -- | Check stake key registration keyRegistration :: - (EraAccounts era, ShelleyEraTxCert era) => + (EraCertState era, ShelleyEraTxCert era) => SourceSignalTarget (ShelleyDELEG era) -> Property keyRegistration @@ -100,10 +100,10 @@ keyRegistration conjoin [ counterexample "a newly registered key should have a reward account" - (isAccountRegistered cred (targetSt ^. accountsL)) + (isAccountRegistered cred (targetSt ^. certDStateL . accountsL)) , counterexample "a newly registered key should have a reward account with 0 balance" - ( ((^. balanceAccountStateL) <$> lookupAccountState cred (targetSt ^. accountsL)) + ( ((^. balanceAccountStateL) <$> lookupAccountState cred (targetSt ^. certDStateL . accountsL)) === Just mempty ) ] @@ -111,7 +111,7 @@ keyRegistration _ = property () -- | Check stake key de-registration keyDeRegistration :: - (EraAccounts era, ShelleyEraTxCert era) => + (EraCertState era, ShelleyEraTxCert era) => SourceSignalTarget (ShelleyDELEG era) -> Property keyDeRegistration @@ -122,16 +122,16 @@ keyDeRegistration conjoin [ counterexample "a deregistered stake key should no longer be in the rewards mapping" - (not (isAccountRegistered cred (targetSt ^. accountsL))) + (not (isAccountRegistered cred (targetSt ^. certDStateL . accountsL))) , counterexample "a deregistered stake key should no longer be in the delegations mapping" - (isNothing (lookupStakePoolDelegation cred (targetSt ^. accountsL))) + (isNothing (lookupStakePoolDelegation cred (targetSt ^. certDStateL . accountsL))) ] keyDeRegistration _ = property () -- | Check stake key delegation keyDelegation :: - (EraAccounts era, ShelleyEraTxCert era) => + (EraCertState era, ShelleyEraTxCert era) => SourceSignalTarget (ShelleyDELEG era) -> Property keyDelegation @@ -142,21 +142,21 @@ keyDelegation conjoin [ counterexample "a delegated key should have a reward account" - (isAccountRegistered stakeCred (targetSt ^. accountsL)) + (isAccountRegistered stakeCred (targetSt ^. certDStateL . accountsL)) , counterexample "a registered stake credential should be delegated" - (lookupStakePoolDelegation stakeCred (targetSt ^. accountsL) === Just poolId) + (lookupStakePoolDelegation stakeCred (targetSt ^. certDStateL . accountsL) === Just poolId) ] keyDelegation _ = property () -- | Check that the sum of balances does not change and that each element -- that is either removed or added has a zero balance. -balancesSumInvariant :: EraAccounts era => SourceSignalTarget (ShelleyDELEG era) -> Property +balancesSumInvariant :: EraCertState era => SourceSignalTarget (ShelleyDELEG era) -> Property balancesSumInvariant SourceSignalTarget {source, target} = let accountsBalances ds = Map.map (^. balanceAccountStateL) (ds ^. accountsL . accountsMapL) - sourceBalances = accountsBalances source - targetBalances = accountsBalances target + sourceBalances = accountsBalances (source ^. certDStateL) + targetBalances = accountsBalances (target ^. certDStateL) balancesSum = F.foldl' (<>) mempty in conjoin [ counterexample @@ -171,7 +171,7 @@ balancesSumInvariant ] checkInstantaneousRewards :: - (EraPParams era, ShelleyEraTxCert era, AtMostEra "Babbage" era) => + (EraPParams era, EraCertState era, ShelleyEraTxCert era, AtMostEra "Babbage" era) => DelegEnv era -> SourceSignalTarget (ShelleyDELEG era) -> Property @@ -183,36 +183,36 @@ checkInstantaneousRewards conjoin [ counterexample "a ReservesMIR certificate should add all entries to the `irwd` mapping" - (Map.keysSet irwd `Set.isSubsetOf` Map.keysSet (iRReserves $ dsIRewards target)) + (Map.keysSet irwd `Set.isSubsetOf` Map.keysSet (iRReserves $ dsIRewards (target ^. certDStateL))) , counterexample "a ReservesMIR certificate should add the total value to the `irwd` map, overwriting any existing entries" ( if hardforkAlonzoAllowMIRTransfer . view ppProtocolVersionL $ ppDE denv then -- In the Alonzo era, repeated fields are added - fold (iRReserves $ dsIRewards source) + fold (iRReserves $ dsIRewards (source ^. certDStateL)) `addDeltaCoin` fold irwd - == fold (iRReserves $ dsIRewards target) + == fold (iRReserves $ dsIRewards (target ^. certDStateL)) else -- Prior to the Alonzo era, repeated fields overridden - fold (iRReserves (dsIRewards source) Map.\\ irwd) + fold (iRReserves (dsIRewards (source ^. certDStateL)) Map.\\ irwd) `addDeltaCoin` fold irwd - == fold (iRReserves $ dsIRewards target) + == fold (iRReserves $ dsIRewards (target ^. certDStateL)) ) ] MirTxCert (MIRCert TreasuryMIR (StakeAddressesMIR irwd)) -> conjoin [ counterexample "a TreasuryMIR certificate should add all entries to the `irwd` mapping" - (Map.keysSet irwd `Set.isSubsetOf` Map.keysSet (iRTreasury $ dsIRewards target)) + (Map.keysSet irwd `Set.isSubsetOf` Map.keysSet (iRTreasury $ dsIRewards (target ^. certDStateL))) , counterexample "a TreasuryMIR certificate should add* the total value to the `irwd` map" ( if hardforkAlonzoAllowMIRTransfer . view ppProtocolVersionL . ppDE $ denv then -- In the Alonzo era, repeated fields are added - fold (iRTreasury $ dsIRewards source) + fold (iRTreasury $ dsIRewards (source ^. certDStateL)) `addDeltaCoin` fold irwd - == fold (iRTreasury $ dsIRewards target) + == fold (iRTreasury $ dsIRewards (target ^. certDStateL)) else -- Prior to the Alonzo era, repeated fields overridden - fold (iRTreasury (dsIRewards source) Map.\\ irwd) + fold (iRTreasury (dsIRewards (source ^. certDStateL)) Map.\\ irwd) `addDeltaCoin` fold irwd - == fold (iRTreasury $ dsIRewards target) + == fold (iRTreasury $ dsIRewards (target ^. certDStateL)) ) ] _ -> property () diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs index 6a8f6e45065..a10d09bb4a3 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs @@ -220,7 +220,7 @@ delegTraceFromBlock :: delegTraceFromBlock chainSt block = ( delegEnv , runShelleyBase $ - Trace.closure @(ShelleyDELEG era) delegEnv delegSt0 blockCerts + Trace.closure @(ShelleyDELEG era) delegEnv (ledgerSt0 ^. lsCertStateL) blockCerts ) where (_tickedChainSt, ledgerEnv, ledgerSt0, txs) = ledgerTraceBase chainSt block @@ -231,8 +231,6 @@ delegTraceFromBlock chainSt block = dummyCertIx = minBound ptr = Ptr (SlotNo32 (fromIntegral slot64)) txIx dummyCertIx in DelegEnv slot (epochFromSlotNo slot) ptr reserves pp - delegSt0 = - ledgerSt0 ^. lsCertStateL . certDStateL delegCert (RegTxCert _) = True delegCert (UnRegTxCert _) = True delegCert (DelegStakeTxCert _ _) = True diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/MirTransfer.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/MirTransfer.hs index 68d76c349d2..7b4c9e232c5 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/MirTransfer.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/MirTransfer.hs @@ -39,9 +39,9 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase, (@?=)) ignoreAllButIRWD :: - Either (NonEmpty (PredicateFailure (ShelleyDELEG ShelleyEra))) (DState ShelleyEra) -> + Either (NonEmpty (PredicateFailure (ShelleyDELEG ShelleyEra))) (CertState ShelleyEra) -> Either (NonEmpty (PredicateFailure (ShelleyDELEG ShelleyEra))) InstantaneousRewards -ignoreAllButIRWD = fmap dsIRewards +ignoreAllButIRWD = fmap (dsIRewards . shelleyCertDState) env :: ProtVer -> ChainAccountState -> DelegEnv ShelleyEra env pv chainAccountState = @@ -72,22 +72,24 @@ testMirTransfer :: Assertion testMirTransfer pv pot target ir acnt (Right expected) = do checkTrace @(ShelleyDELEG ShelleyEra) runShelleyBase (env pv acnt) $ - pure (dStateWithRewards ir) .- MirTxCert (MIRCert pot target) .->> dStateWithRewards expected + pure (certStateWithRewards ir) .- MirTxCert (MIRCert pot target) .->> certStateWithRewards expected testMirTransfer pv pot target ir acnt predicateFailure@(Left _) = do let st = runShelleyBase $ applySTSTest @(ShelleyDELEG ShelleyEra) - (TRC (env pv acnt, dStateWithRewards ir, MirTxCert (MIRCert pot target))) + (TRC (env pv acnt, certStateWithRewards ir, MirTxCert (MIRCert pot target))) ignoreAllButIRWD st @?= predicateFailure -dStateWithRewards :: InstantaneousRewards -> DState ShelleyEra -dStateWithRewards ir = - DState - { dsAccounts = def - , dsFutureGenDelegs = Map.empty - , dsGenDelegs = GenDelegs Map.empty - , dsIRewards = ir - } +certStateWithRewards :: InstantaneousRewards -> CertState ShelleyEra +certStateWithRewards ir = + def + & certDStateL + .~ DState + { dsAccounts = def + , dsFutureGenDelegs = Map.empty + , dsGenDelegs = GenDelegs Map.empty + , dsIRewards = ir + } alice :: Credential 'Staking alice = (KeyHashObj . hashKey . snd) $ mkKeyPair (RawSeed 0 0 0 0 1) diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 821a57267ef..da9f5ec7910 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.19.0.0 +* Add `iRReservesL`, `iRTreasuryL`, `iRDeltaReservesL`, `iRDeltaTreasuryL` * Add `spsDelegators` field to `StakePool` * Add `spsDelegatorsL` * Change parameter type of `removeStakePoolDelegations` from `Set (KeyHash 'StakePool)` to `Set (Credential 'Staking)` 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 dbe41ff5358..a902420115c 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs @@ -35,8 +35,12 @@ module Cardano.Ledger.State.CertState ( Obligations (..), sumObligation, -- Lenses - dsGenDelegsL, + iRReservesL, dsIRewardsL, + dsGenDelegsL, + iRTreasuryL, + iRDeltaReservesL, + iRDeltaTreasuryL, dsFutureGenDelegsL, psStakePoolsL, psFutureStakePoolsL, @@ -434,6 +438,18 @@ dsGenDelegsL = lens dsGenDelegs (\ds u -> ds {dsGenDelegs = u}) dsIRewardsL :: Lens' (DState era) InstantaneousRewards dsIRewardsL = lens dsIRewards (\ds u -> ds {dsIRewards = u}) +iRReservesL :: Lens' InstantaneousRewards (Map (Credential 'Staking) Coin) +iRReservesL = lens iRReserves (\ir m -> ir {iRReserves = m}) + +iRTreasuryL :: Lens' InstantaneousRewards (Map (Credential 'Staking) Coin) +iRTreasuryL = lens iRTreasury (\ir m -> ir {iRTreasury = m}) + +iRDeltaReservesL :: Lens' InstantaneousRewards DeltaCoin +iRDeltaReservesL = lens deltaReserves (\ir d -> ir {deltaReserves = d}) + +iRDeltaTreasuryL :: Lens' InstantaneousRewards DeltaCoin +iRDeltaTreasuryL = lens deltaTreasury (\ir d -> ir {deltaTreasury = d}) + dsFutureGenDelegsL :: Lens' (DState era) (Map FutureGenDeleg GenDelegPair) dsFutureGenDelegsL = lens dsFutureGenDelegs (\ds u -> ds {dsFutureGenDelegs = u}) From 306a5d13540dda874d1c8385412efb130f259f62 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 9 Oct 2025 00:02:13 +0100 Subject: [PATCH 07/13] Update `StakePoolState` delegs in shelley --- .../src/Cardano/Ledger/Shelley/Rules/Deleg.hs | 48 +++++++++++++++---- .../Ledger/Shelley/Examples/Combinators.hs | 10 ++++ 2 files changed, 50 insertions(+), 8 deletions(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs index 555749b3a33..f479079b7c6 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs @@ -265,23 +265,39 @@ delegationTransition = do let compactDeposit = compactCoinOrError (pp ^. ppKeyDepositL) pure $ certState & certDStateL . accountsL %~ registerShelleyAccount cred ptr compactDeposit Nothing UnRegTxCert cred -> do - let !(mAccountState, !accounts) = unregisterShelleyAccount cred (ds ^. accountsL) + let !(!mAccountState, !accounts) = unregisterShelleyAccount cred (ds ^. accountsL) checkStakeKeyHasZeroRewardBalance = do accountState <- mAccountState let accountBalance = accountState ^. balanceAccountStateL guard (accountBalance /= mempty) Just $ fromCompact accountBalance - -- (hk ∈ dom (rewards ds)) - isJust mAccountState ?! StakeKeyNotRegisteredDELEG cred failOnJust checkStakeKeyHasZeroRewardBalance StakeKeyNonZeroAccountBalanceDELEG - pure $ certState & certDStateL . accountsL .~ accounts + -- (hk ∈ dom (rewards ds)) + case mAccountState of + Nothing -> do + failBecause $ StakeKeyNotRegisteredDELEG cred + pure certState + Just accountState -> + pure $ + certState + & certDStateL . accountsL .~ accounts + & certPStateL + %~ unDelegStakePool cred (accountState ^. stakePoolDelegationAccountStateL) Nothing DelegStakeTxCert cred stakePool -> do -- note that pattern match is used instead of cwitness and dpool, as in the spec -- (hk ∈ dom (rewards ds)) - isAccountRegistered cred (ds ^. accountsL) ?! StakeDelegationImpossibleDELEG cred - pure $ - certState - & certDStateL . accountsL %~ adjustAccountState (stakePoolDelegationAccountStateL ?~ stakePool) cred + case lookupAccountState cred (ds ^. accountsL) of + Nothing -> do + failBecause $ StakeDelegationImpossibleDELEG cred + pure certState + Just accountState -> + pure $ + certState + & certDStateL . accountsL %~ adjustAccountState (stakePoolDelegationAccountStateL ?~ stakePool) cred + & certPStateL %~ \ps -> + ps + & unDelegStakePool cred (accountState ^. stakePoolDelegationAccountStateL) (Just stakePool) + & psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.insert cred) stakePool GenesisDelegTxCert gkh vkh vrf -> do sp <- liftSTS $ asks stabilityWindow -- note that pattern match is used instead of genesisDeleg, as in the spec @@ -404,3 +420,19 @@ updateReservesAndTreasury targetPot combinedMap available certState = do case targetPot of ReservesMIR -> certState & certDStateL . dsIRewardsL . iRReservesL .~ combinedMap TreasuryMIR -> certState & certDStateL . dsIRewardsL . iRTreasuryL .~ combinedMap + +unDelegStakePool :: + Credential 'Staking -> + Maybe (KeyHash 'StakePool) -> + Maybe (KeyHash 'StakePool) -> + PState era -> + PState era +unDelegStakePool stakeCred mCurStakePool mNewPool = + maybe + id + (\oldPool -> psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.delete stakeCred) oldPool) + (mCurStakePool >>= stakePoolToUnDeleg) + where + stakePoolToUnDeleg oldPool + | Just oldPool /= mNewPool = Just oldPool + | otherwise = Nothing 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 68feb065e11..6745ceef89a 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 @@ -95,6 +95,7 @@ import Data.Foldable (fold) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) +import qualified Data.Set as Set import Data.Word (Word64) import GHC.Stack (HasCallStack) import Lens.Micro @@ -211,12 +212,19 @@ deregStakeCred cred cs = cs {chainNes = nes} chainNes cs & nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL .~ accounts' & nesEsL . esLStateL . lsUTxOStateL . utxosDepositedL %~ (<-> refund) + & nesEsL . esLStateL . lsCertStateL . certPStateL %~ adjustPState accounts = chainNes cs ^. nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL (mAccountState, accounts') = unregisterShelleyAccount cred accounts refund = fromCompact (fromJust mAccountState ^. depositAccountStateL) + currentDeleg = Map.lookup cred (accounts ^. accountsMapL) >>= (^. stakePoolDelegationAccountStateL) + adjustPState = + maybe + id + (\oldPool -> psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.delete cred) oldPool) + currentDeleg -- | = New Delegation -- @@ -234,6 +242,8 @@ delegation cred poolId cs = cs {chainNes = nes} chainNes cs & nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL . accountsMapL %~ Map.adjust (stakePoolDelegationAccountStateL .~ Just poolId) cred + & nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL + %~ Map.adjust (spsDelegatorsL %~ Set.insert cred) poolId -- | Register a stake pool. regPool :: From da6ab9dbd1a035affb5b7b80444386bc434bf106 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 10 Oct 2025 15:06:42 +0100 Subject: [PATCH 08/13] Update shelley `Transition` to set the pool delegations and add a test for it --- .../src/Cardano/Ledger/Shelley/Transition.hs | 15 +++++--- .../Test/Cardano/Ledger/Shelley/Imp.hs | 2 ++ .../Cardano/Ledger/Shelley/Imp/DelegSpec.hs | 35 +++++++++++++++++++ 3 files changed, 48 insertions(+), 4 deletions(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs index 0c3f946278a..10f4803feb9 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Transition.hs @@ -75,6 +75,7 @@ import Data.Default import Data.Kind import qualified Data.ListMap as ListMap import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Data.Typeable import Data.Void (Void) import GHC.Generics (Generic) @@ -409,14 +410,20 @@ shelleyRegisterInitialAccounts :: NewEpochState era shelleyRegisterInitialAccounts ShelleyGenesisStaking {sgsStake} nes = nes - & nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL %~ \initAccounts -> - foldr registerAndDelegate initAccounts $ zip (ListMap.toList sgsStake) ptrs + & nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL .~ updatedAccounts + & nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL .~ updatedStakePoolStates where stakePools = nes ^. nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL + initialAccounts = nes ^. nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL deposit = compactCoinOrError $ nes ^. nesEsL . curPParamsEpochStateL . ppKeyDepositL - registerAndDelegate ((stakeKeyHash, stakePool), ptr) !accounts + + !(!updatedAccounts, !updatedStakePoolStates) = + foldr registerAndDelegate (initialAccounts, stakePools) (zip (ListMap.toList sgsStake) ptrs) + registerAndDelegate ((stakeKeyHash, stakePool), ptr) (!accounts, !stakePoolMap) | stakePool `Map.member` stakePools = - registerShelleyAccount (KeyHashObj stakeKeyHash) ptr deposit (Just stakePool) accounts + ( registerShelleyAccount (KeyHashObj stakeKeyHash) ptr deposit (Just stakePool) accounts + , Map.adjust (spsDelegatorsL %~ Set.insert (KeyHashObj stakeKeyHash)) stakePool stakePoolMap + ) | otherwise = error $ "Invariant of a delegation of " diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs index a3e3ddfb2d7..00b5fed06cf 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs @@ -10,6 +10,7 @@ module Test.Cardano.Ledger.Shelley.Imp (spec, shelleyEraSpecificSpec) where import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.Rules +import Cardano.Ledger.Shelley.State (ShelleyEraAccounts) import Test.Cardano.Ledger.Imp.Common import qualified Test.Cardano.Ledger.Shelley.Imp.DelegSpec as Deleg import qualified Test.Cardano.Ledger.Shelley.Imp.EpochSpec as Epoch @@ -41,6 +42,7 @@ spec = do shelleyEraSpecificSpec :: forall era. ( ShelleyEraImp era + , ShelleyEraAccounts era , InjectRuleFailure "LEDGER" ShelleyDelegsPredFailure era ) => SpecWith (ImpInit (LedgerSpec era)) diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/DelegSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/DelegSpec.hs index 564f76958ab..c70f07cdc73 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/DelegSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/DelegSpec.hs @@ -16,8 +16,14 @@ import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin (Coin (Coin)) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Shelley.Genesis +import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Rules import Cardano.Ledger.Shelley.Scripts +import Cardano.Ledger.Shelley.State (ShelleyEraAccounts) +import Cardano.Ledger.Shelley.Transition (shelleyRegisterInitialAccounts) +import Cardano.Ledger.State (accountsL, accountsMapL, stakePoolDelegationAccountStateL) +import qualified Data.ListMap as LM import qualified Data.Map.Strict as Map import Lens.Micro import Test.Cardano.Ledger.Imp.Common @@ -26,6 +32,7 @@ import Test.Cardano.Ledger.Shelley.ImpTest shelleyEraSpecificSpec :: ( ShelleyEraImp era + , ShelleyEraAccounts era , InjectRuleFailure "LEDGER" ShelleyDelegsPredFailure era ) => SpecWith (ImpInit (LedgerSpec era)) @@ -100,6 +107,34 @@ shelleyEraSpecificSpec = do getBalance otherStakeCred `shouldReturn` Coin 0 expectNotRegisteredRewardAddress rewardAccount + it "Transition creates the delegations correctly" $ do + pool1 <- freshKeyHash >>= \kh -> kh <$ registerPool kh + pool2 <- freshKeyHash >>= \kh -> kh <$ registerPool kh + pool3 <- freshKeyHash >>= \kh -> kh <$ registerPool kh + poolParams <- freshKeyHash >>= \kh -> registerRewardAccount >>= freshPoolParams kh + deleg1 <- freshKeyHash >>= \kh -> kh <$ registerStakeCredential (KeyHashObj kh) + deleg2 <- freshKeyHash >>= \kh -> kh <$ registerStakeCredential (KeyHashObj kh) + deleg3 <- freshKeyHash >>= \kh -> kh <$ registerStakeCredential (KeyHashObj kh) + nes <- getsNES id + let sgs = + ShelleyGenesisStaking + { sgsPools = LM.ListMap [(pool1, poolParams), (pool2, poolParams), (pool3, poolParams)] + , sgsStake = LM.ListMap [(deleg1, pool1), (deleg2, pool1), (deleg3, pool2)] + } + let updatedNES = shelleyRegisterInitialAccounts sgs nes + delegateStake (KeyHashObj deleg1) pool1 + delegateStake (KeyHashObj deleg2) pool1 + delegateStake (KeyHashObj deleg3) pool2 + getPoolsState <$> (getsNES id) `shouldReturn` getPoolsState updatedNES + getDelegs deleg1 updatedNES `shouldReturn` Just pool1 + getDelegs deleg2 updatedNES `shouldReturn` Just pool1 + getDelegs deleg3 updatedNES `shouldReturn` Just pool2 + where + getDelegs kh nes = do + let accounts = nes ^. nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL . accountsMapL + pure $ Map.lookup (KeyHashObj kh) accounts >>= (^. stakePoolDelegationAccountStateL) + getPoolsState nes = nes ^. nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL + spec :: ShelleyEraImp era => SpecWith (ImpInit (LedgerSpec era)) From 51f426749f9853f9037a3e182f43df17af9cc019 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 10 Oct 2025 15:08:01 +0100 Subject: [PATCH 09/13] Update conway `Transition` to set the pool delegations and add a test for it --- eras/conway/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Conway/Transition.hs | 16 +++++++--- .../Cardano/Ledger/Conway/Imp/DelegSpec.hs | 32 ++++++++++++++++++- 3 files changed, 44 insertions(+), 5 deletions(-) diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index dc6c272d717..b38dbc8b89e 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.21.0.0 +* Expose `conwayRegisterInitialAccounts` * Add `TxLevel` argument to `Tx` and `TxBody` * Add `HasEraTxLevel` instances for `Tx` and `TxBody` * Add `EraTxLevel` instance diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Transition.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Transition.hs index 135e29cdbaa..7b33d11b587 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Transition.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Transition.hs @@ -16,6 +16,7 @@ module Cardano.Ledger.Conway.Transition ( TransitionConfig (..), toConwayTransitionConfigPairs, registerDRepsThenDelegs, + conwayRegisterInitialAccounts, conwayRegisterInitialFundsThenStaking, ) where @@ -44,6 +45,7 @@ import Data.Aeson (KeyValue (..)) import Data.ListMap (ListMap) import qualified Data.ListMap as ListMap import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import GHC.Generics import GHC.Stack import Lens.Micro @@ -127,14 +129,20 @@ conwayRegisterInitialAccounts :: NewEpochState era conwayRegisterInitialAccounts ShelleyGenesisStaking {sgsStake} nes = nes - & nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL %~ \initAccounts -> - foldr registerAndDelegate initAccounts $ ListMap.toList sgsStake + & nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL .~ updatedAccounts + & nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL .~ updatedStakePoolStates where stakePools = nes ^. nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL + initialAccounts = nes ^. nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL deposit = compactCoinOrError $ nes ^. nesEsL . curPParamsEpochStateL . ppKeyDepositL - registerAndDelegate (stakeKeyHash, stakePool) !accounts + + !(!updatedAccounts, !updatedStakePoolStates) = + foldr registerAndDelegate (initialAccounts, stakePools) (ListMap.toList sgsStake) + registerAndDelegate (stakeKeyHash, stakePool) (!accounts, !stakePoolMap) | stakePool `Map.member` stakePools = - registerConwayAccount (KeyHashObj stakeKeyHash) deposit (Just (DelegStake stakePool)) accounts + ( (registerConwayAccount (KeyHashObj stakeKeyHash) deposit (Just (DelegStake stakePool)) accounts) + , Map.adjust (spsDelegatorsL %~ Set.insert (KeyHashObj stakeKeyHash)) stakePool stakePoolMap + ) | otherwise = error $ "Invariant of a delegation of " diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs index 8e48be66e01..ae917166f53 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs @@ -27,6 +27,7 @@ import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Conway.Rules (ConwayDelegPredFailure (..)) import Cardano.Ledger.Conway.State hiding (balance) +import Cardano.Ledger.Conway.Transition (conwayRegisterInitialAccounts) import Cardano.Ledger.Conway.TxCert import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.DRep @@ -34,8 +35,10 @@ import Cardano.Ledger.Plutus ( SLanguage (..), hashPlutusScript, ) +import Cardano.Ledger.Shelley.Genesis (ShelleyGenesisStaking (..)) import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Val (Val (..)) +import qualified Data.ListMap as LM import qualified Data.Map.Strict as Map import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set @@ -238,7 +241,7 @@ spec = do & bodyTxL . certsTxBodyL .~ [DelegTxCert cred (DelegVote (DRepCredential drepCred))] - expectDelegatedVote cred (DRepCredential drepCred) + expectDelegatedVote cred (DRepCredential drepCred) it "Delegate vote of registered stake credentials to unregistered drep" $ do RewardAccount _ cred <- registerRewardAccount @@ -532,6 +535,29 @@ spec = do expectDelegatedToPool cred poolKh' expectNotDelegatedToPool cred poolKh expectDelegatedVote cred (DRepCredential drepCred) + + it "Transition creates the delegations correctly" $ do + pool1 <- freshKeyHash >>= \kh -> kh <$ registerPool kh + pool2 <- freshKeyHash >>= \kh -> kh <$ registerPool kh + pool3 <- freshKeyHash >>= \kh -> kh <$ registerPool kh + poolParams <- freshKeyHash >>= \kh -> registerRewardAccount >>= freshPoolParams kh + deleg1 <- freshKeyHash >>= \kh -> kh <$ registerStakeCredential (KeyHashObj kh) + deleg2 <- freshKeyHash >>= \kh -> kh <$ registerStakeCredential (KeyHashObj kh) + deleg3 <- freshKeyHash >>= \kh -> kh <$ registerStakeCredential (KeyHashObj kh) + nes <- getsNES id + let sgs = + ShelleyGenesisStaking + { sgsPools = LM.ListMap [(pool1, poolParams), (pool2, poolParams), (pool3, poolParams)] + , sgsStake = LM.ListMap [(deleg1, pool1), (deleg2, pool1), (deleg3, pool2)] + } + let updatedNES = conwayRegisterInitialAccounts sgs nes + delegateStake (KeyHashObj deleg1) pool1 + delegateStake (KeyHashObj deleg2) pool1 + delegateStake (KeyHashObj deleg3) pool2 + getPoolsState <$> (getsNES id) `shouldReturn` getPoolsState updatedNES + getDelegs deleg1 updatedNES `shouldReturn` Just pool1 + getDelegs deleg2 updatedNES `shouldReturn` Just pool1 + getDelegs deleg3 updatedNES `shouldReturn` Just pool2 where expectDelegatedVote :: HasCallStack => Credential 'Staking -> DRep -> ImpTestM era () expectDelegatedVote cred drep = do @@ -562,3 +588,7 @@ spec = do assertBool ("Expected no drep state delegation to contain the stake credential: " <> show cred) (all (Set.notMember cred . drepDelegs) dreps) + getDelegs kh nes = do + let accounts = nes ^. nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL . accountsMapL + pure $ Map.lookup (KeyHashObj kh) accounts >>= (^. stakePoolDelegationAccountStateL) + getPoolsState nes = nes ^. nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL From e0f9b3dad7cadbae246450f63bab2e77e63d4943 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 14 Oct 2025 14:51:59 +0100 Subject: [PATCH 10/13] Intern stake credentials in `StakePoolState` CBOR decoder --- .../src/Cardano/Ledger/State/StakePool.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) 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 5e1bc4a1a83..215207781a0 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs @@ -86,8 +86,10 @@ import Cardano.Ledger.Binary ( DecShareCBOR (..), EncCBOR (..), EncCBORGroup (..), + Interns, decodeNullStrictMaybe, decodeRecordNamed, + decodeRecordNamedT, decodeRecordSum, encodeListLen, encodeNullStrictMaybe, @@ -106,6 +108,7 @@ import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..), KeyRoleVRF (StakePoolVRF import Cardano.Ledger.Orphans () import Control.DeepSeq (NFData) import Control.Monad (unless) +import Control.Monad.Trans (lift) import Data.Aeson (FromJSON (..), ToJSON (..), Value, (.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson import Data.Aeson.Types (Parser, explicitParseField) @@ -211,7 +214,20 @@ instance DecCBOR StakePoolState where lift decCBOR + <*> lift decCBOR + <*> lift decCBOR + <*> lift decCBOR + <*> lift decCBOR + <*> lift decCBOR + <*> lift decCBOR + <*> lift decCBOR + <*> lift decCBOR + <*> decSharePlusCBOR instance Default StakePoolState where def = From ab78a9e805cbc246319fb7633bf95d969561bac7 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 23 Oct 2025 17:09:57 +0100 Subject: [PATCH 11/13] Refactor PState update logic to handle stake undelegation/redelegation uniformly across eras --- .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 61 +++++++------------ .../src/Cardano/Ledger/Shelley/Rules/Deleg.hs | 23 +------ libs/cardano-ledger-core/CHANGELOG.md | 1 + .../src/Cardano/Ledger/State/CertState.hs | 28 ++++++++- 4 files changed, 53 insertions(+), 60 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs index 8633a33042e..0c4e4425161 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -67,6 +67,7 @@ import Control.State.Transition ( State, TRC (TRC), TransitionRule, + failBecause, failOnJust, judgmentContext, transitionRules, @@ -201,10 +202,6 @@ conwayDelegTransition = do else IncorrectDepositDELEG deposit checkStakeKeyNotRegistered stakeCred = not (isAccountRegistered stakeCred accounts) ?! StakeKeyRegisteredDELEG stakeCred - checkStakeKeyIsRegistered stakeCred = do - let mAccountState = lookupAccountState stakeCred accounts - isJust mAccountState ?! StakeKeyNotRegisteredDELEG stakeCred - pure $ mAccountState >>= accountStateDelegatee checkStakeDelegateeRegistered = let checkPoolRegistered targetPool = targetPool `Map.member` pools ?! DelegateeStakePoolNotRegisteredDELEG targetPool @@ -253,18 +250,23 @@ conwayDelegTransition = do guard (balanceCompact /= mempty) Just $ fromCompact balanceCompact failOnJust checkInvalidRefund id - isJust mAccountState ?! StakeKeyNotRegisteredDELEG stakeCred failOnJust checkStakeKeyHasZeroRewardBalance StakeKeyHasNonZeroRewardAccountBalanceDELEG - pure $ - certState - & certDStateL . accountsL .~ newAccounts - & certVStateL %~ unDelegDRep stakeCred mCurDelegatee - & certPStateL %~ unDelegStakePool stakeCred mCurDelegatee Nothing + case mAccountState of + Nothing -> do + failBecause $ StakeKeyNotRegisteredDELEG stakeCred + pure certState + Just accountState -> + pure $ + certState + & certDStateL . accountsL .~ newAccounts + & certVStateL %~ unDelegDRep stakeCred mCurDelegatee + & certPStateL %~ unDelegReDelegStakePool stakeCred accountState Nothing ConwayDelegCert stakeCred delegatee -> do - mCurDelegatee <- checkStakeKeyIsRegistered stakeCred + let mAccountState = lookupAccountState stakeCred accounts + isJust mAccountState ?! StakeKeyNotRegisteredDELEG stakeCred checkStakeDelegateeRegistered delegatee pure $ - processDelegationInternal (pvMajor pv < natVersion @10) stakeCred mCurDelegatee delegatee certState + processDelegationInternal (pvMajor pv < natVersion @10) stakeCred mAccountState delegatee certState ConwayRegDelegCert stakeCred delegatee deposit -> do checkDepositAgainstPParams deposit checkStakeKeyNotRegistered stakeCred @@ -287,9 +289,8 @@ processDelegation :: CertState era processDelegation stakeCred newDelegatee !certState = certState' where - !certState' = processDelegationInternal False stakeCred mCurDelegatee newDelegatee certState + !certState' = processDelegationInternal False stakeCred mAccountState newDelegatee certState mAccountState = Map.lookup stakeCred (certState ^. certDStateL . accountsL . accountsMapL) - mCurDelegatee = mAccountState >>= accountStateDelegatee -- | Same as `processDelegation`, except it expects the current delegation supplied as an -- argument, because in ledger rules we already have it readily available. @@ -299,23 +300,27 @@ processDelegationInternal :: Bool -> -- | Delegator Credential 'Staking -> - -- | Current delegatee for the above stake credential that needs to be cleaned up. - Maybe Delegatee -> + -- | Account state for the above stake credential + Maybe (AccountState era) -> -- | New delegatee Delegatee -> CertState era -> CertState era -processDelegationInternal preserveIncorrectDelegation stakeCred mCurDelegatee newDelegatee = +processDelegationInternal preserveIncorrectDelegation stakeCred mAccountState newDelegatee = case newDelegatee of DelegStake sPool -> delegStake sPool DelegVote dRep -> delegVote dRep DelegStakeVote sPool dRep -> delegVote dRep . delegStake sPool where + mCurDelegatee = mAccountState >>= accountStateDelegatee delegStake stakePool cState = cState & certDStateL . accountsL %~ adjustAccountState (stakePoolDelegationAccountStateL ?~ stakePool) stakeCred - & certPStateL %~ adjustPState stakePool + & maybe + (certPStateL . psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.insert stakeCred) stakePool) + (\accountState -> certPStateL %~ unDelegReDelegStakePool stakeCred accountState (Just stakePool)) + mAccountState delegVote dRep cState = let cState' = cState @@ -331,26 +336,6 @@ processDelegationInternal preserveIncorrectDelegation stakeCred mCurDelegatee ne let dRepState' = dRepState {drepDelegs = Set.insert stakeCred (drepDelegs dRepState)} in cState' & certVStateL . vsDRepsL .~ Map.insert targetDRep dRepState' dReps _ -> cState' - adjustPState newPool = - (psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.insert stakeCred) newPool) - . unDelegStakePool stakeCred mCurDelegatee (Just newPool) - -unDelegStakePool :: - Credential 'Staking -> - Maybe Delegatee -> - Maybe (KeyHash 'StakePool) -> - PState era -> - PState era -unDelegStakePool stakeCred mCurDelegatee mNewPool = - maybe - id - (\oldPool -> psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.delete stakeCred) oldPool) - (mCurDelegatee >>= stakePoolToUnDeleg) - where - stakePoolToUnDeleg = \case - DelegStake oldPool | Just oldPool /= mNewPool -> Just oldPool - DelegStakeVote oldPool _ | Just oldPool /= mNewPool -> Just oldPool - _ -> Nothing unDelegDRep :: Credential 'Staking -> diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs index f479079b7c6..6e177e8ee7e 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs @@ -282,7 +282,7 @@ delegationTransition = do certState & certDStateL . accountsL .~ accounts & certPStateL - %~ unDelegStakePool cred (accountState ^. stakePoolDelegationAccountStateL) Nothing + %~ unDelegReDelegStakePool cred accountState Nothing DelegStakeTxCert cred stakePool -> do -- note that pattern match is used instead of cwitness and dpool, as in the spec -- (hk ∈ dom (rewards ds)) @@ -294,10 +294,7 @@ delegationTransition = do pure $ certState & certDStateL . accountsL %~ adjustAccountState (stakePoolDelegationAccountStateL ?~ stakePool) cred - & certPStateL %~ \ps -> - ps - & unDelegStakePool cred (accountState ^. stakePoolDelegationAccountStateL) (Just stakePool) - & psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.insert cred) stakePool + & certPStateL %~ unDelegReDelegStakePool cred accountState (Just stakePool) GenesisDelegTxCert gkh vkh vrf -> do sp <- liftSTS $ asks stabilityWindow -- note that pattern match is used instead of genesisDeleg, as in the spec @@ -420,19 +417,3 @@ updateReservesAndTreasury targetPot combinedMap available certState = do case targetPot of ReservesMIR -> certState & certDStateL . dsIRewardsL . iRReservesL .~ combinedMap TreasuryMIR -> certState & certDStateL . dsIRewardsL . iRTreasuryL .~ combinedMap - -unDelegStakePool :: - Credential 'Staking -> - Maybe (KeyHash 'StakePool) -> - Maybe (KeyHash 'StakePool) -> - PState era -> - PState era -unDelegStakePool stakeCred mCurStakePool mNewPool = - maybe - id - (\oldPool -> psStakePoolsL %~ Map.adjust (spsDelegatorsL %~ Set.delete stakeCred) oldPool) - (mCurStakePool >>= stakePoolToUnDeleg) - where - stakePoolToUnDeleg oldPool - | Just oldPool /= mNewPool = Just oldPool - | otherwise = Nothing diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index da9f5ec7910..ca88f2fc94e 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.19.0.0 +* Add `unDelegReDelegStakePool` to `CertState` module * Add `iRReservesL`, `iRTreasuryL`, `iRDeltaReservesL`, `iRDeltaTreasuryL` * Add `spsDelegators` field to `StakePool` * Add `spsDelegatorsL` 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 a902420115c..2bb6eea80b9 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs @@ -34,6 +34,7 @@ module Cardano.Ledger.State.CertState ( lookupRewardDState, Obligations (..), sumObligation, + unDelegReDelegStakePool, -- Lenses iRReservesL, dsIRewardsL, @@ -80,7 +81,7 @@ import Cardano.Ledger.DRep (DRep (..), DRepState (..)) import Cardano.Ledger.Hashes (GenDelegPair (..), GenDelegs (..)) import Cardano.Ledger.Slot (EpochNo (..), SlotNo (..)) import Cardano.Ledger.State.Account -import Cardano.Ledger.State.StakePool (StakePoolState (..)) +import Cardano.Ledger.State.StakePool (StakePoolState (..), spsDelegatorsL) import Control.DeepSeq (NFData (..)) import Control.Monad.Trans import Data.Aeson (ToJSON (..), object, (.=)) @@ -89,6 +90,7 @@ import qualified Data.Foldable as F import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Data.Word (Word64) import GHC.Generics (Generic) @@ -273,6 +275,30 @@ instance ToKeyValuePairs (PState era) where , "retiring" .= psRetiring ] +-- | Reverses stake pool delegation. +-- To be called when a stake credential is unregistered or its delegation target changes. +-- If the new delegation matches the previous one, this is a noop. +unDelegReDelegStakePool :: + EraAccounts era => + Credential 'Staking -> + -- | Account that is losing its current delegation and/or acquiring a new one + AccountState era -> + -- | Optional new delegation target. Use 'Nothing' when the stake credential unregisters. + Maybe (KeyHash 'StakePool) -> + PState era -> + PState era +unDelegReDelegStakePool stakeCred accountState mNewStakePool = + fromMaybe (psStakePoolsL %~ addNewDelegation) $ do + curStakePool <- accountState ^. stakePoolDelegationAccountStateL + pure $ + -- no need to update the set of delegations if the delegation is unchanged + if Just curStakePool == mNewStakePool + then id + else + psStakePoolsL %~ addNewDelegation . Map.adjust (spsDelegatorsL %~ Set.delete stakeCred) curStakePool + where + addNewDelegation = maybe id (Map.adjust (spsDelegatorsL %~ Set.insert stakeCred)) mNewStakePool + data CommitteeAuthorization = -- | Member authorized with a Hot credential acting on behalf of their Cold credential CommitteeHotCredential !(Credential 'HotCommitteeRole) From 7e5ab5d6b0ec3324fb4c2898985b1ca4675320d2 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 24 Oct 2025 17:25:55 +0100 Subject: [PATCH 12/13] Refactor VState update logic to handle dRep undelegation/redelegation --- eras/conway/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 44 +++++-------------- .../src/Cardano/Ledger/Conway/State/VState.hs | 35 ++++++++++++++- 3 files changed, 46 insertions(+), 34 deletions(-) diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index b38dbc8b89e..b0890c1fb66 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.21.0.0 +* Add `unDelegReDelegDRep` to `VState` module * Expose `conwayRegisterInitialAccounts` * Add `TxLevel` argument to `Tx` and `TxBody` * Add `HasEraTxLevel` instances for `Tx` and `TxBody` diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs index 0c4e4425161..05a22388435 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -227,7 +227,6 @@ conwayDelegTransition = do %~ registerConwayAccount stakeCred ppKeyDepositCompact Nothing ConwayUnRegCert stakeCred sMayRefund -> do let (mAccountState, newAccounts) = unregisterConwayAccount stakeCred accounts - mCurDelegatee = mAccountState >>= accountStateDelegatee checkInvalidRefund = do SJust suppliedRefund <- Just sMayRefund -- we don't want to report invalid refund when stake credential is not registered: @@ -259,7 +258,7 @@ conwayDelegTransition = do pure $ certState & certDStateL . accountsL .~ newAccounts - & certVStateL %~ unDelegDRep stakeCred mCurDelegatee + & certVStateL %~ unDelegReDelegDRep stakeCred accountState Nothing & certPStateL %~ unDelegReDelegStakePool stakeCred accountState Nothing ConwayDelegCert stakeCred delegatee -> do let mAccountState = lookupAccountState stakeCred accounts @@ -312,7 +311,6 @@ processDelegationInternal preserveIncorrectDelegation stakeCred mAccountState ne DelegVote dRep -> delegVote dRep DelegStakeVote sPool dRep -> delegVote dRep . delegStake sPool where - mCurDelegatee = mAccountState >>= accountStateDelegatee delegStake stakePool cState = cState & certDStateL . accountsL @@ -322,33 +320,13 @@ processDelegationInternal preserveIncorrectDelegation stakeCred mAccountState ne (\accountState -> certPStateL %~ unDelegReDelegStakePool stakeCred accountState (Just stakePool)) mAccountState delegVote dRep cState = - let cState' = - cState - & certDStateL . accountsL - %~ adjustAccountState (dRepDelegationAccountStateL ?~ dRep) stakeCred - & certVStateL %~ unDelegDRep stakeCred mCurDelegatee - dReps - | preserveIncorrectDelegation = cState ^. certVStateL . vsDRepsL - | otherwise = cState' ^. certVStateL . vsDRepsL - in case dRep of - DRepCredential targetDRep - | Just dRepState <- Map.lookup targetDRep dReps -> - let dRepState' = dRepState {drepDelegs = Set.insert stakeCred (drepDelegs dRepState)} - in cState' & certVStateL . vsDRepsL .~ Map.insert targetDRep dRepState' dReps - _ -> cState' - -unDelegDRep :: - Credential 'Staking -> - Maybe Delegatee -> - VState era -> - VState era -unDelegDRep stakeCred mCurDelegatee = - maybe - id - (\dRepCred -> vsDRepsL %~ Map.adjust (drepDelegsL %~ Set.delete stakeCred) dRepCred) - (mCurDelegatee >>= drepToUndeleg) - where - drepToUndeleg = \case - DelegVote (DRepCredential dRepCred) -> Just dRepCred - DelegStakeVote _ (DRepCredential dRepCred) -> Just dRepCred - _ -> Nothing + cState + & certDStateL . accountsL %~ adjustAccountState (dRepDelegationAccountStateL ?~ dRep) stakeCred + & maybe + (certVStateL %~ insertDRepDeleg dRep) + (\accountState -> certVStateL %~ unDelegReDelegDRep stakeCred accountState (Just dRep)) + (guard (not preserveIncorrectDelegation) >> mAccountState) + insertDRepDeleg dRep = case dRep of + DRepCredential dRepCred -> + vsDRepsL %~ Map.adjust (drepDelegsL %~ Set.insert stakeCred) dRepCred + _ -> id diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/State/VState.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/State/VState.hs index 99ba7c5c8cc..b53f2e01067 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/State/VState.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/State/VState.hs @@ -17,6 +17,7 @@ module Cardano.Ledger.Conway.State.VState ( vsNumDormantEpochsL, vsActualDRepExpiry, lookupDepositVState, + unDelegReDelegDRep, ) where import Cardano.Ledger.BaseTypes (KeyValuePairs (..), ToKeyValuePairs (..), binOpEpochNo) @@ -33,8 +34,10 @@ import Cardano.Ledger.Binary ( import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), ( + Credential 'Staking -> + -- | Account that is losing its current delegation and/or acquiring a new one + AccountState era -> + -- | Potential new delegation. In case when stake credential unregisters this must be `Nothing`. + Maybe DRep -> + VState era -> + VState era +unDelegReDelegDRep stakeCred accountState mNewDRep = + fromMaybe (vsDRepsL %~ addNewDelegation) $ do + dRep@(DRepCredential dRepCred) <- accountState ^. dRepDelegationAccountStateL + pure $ + -- There is no need to update set of delegations if delegation is unchanged + if Just dRep == mNewDRep + then id + else + vsDRepsL %~ addNewDelegation . Map.adjust (drepDelegsL %~ Set.delete stakeCred) dRepCred + where + addNewDelegation = + case mNewDRep of + Just (DRepCredential dRepCred) -> + Map.adjust (drepDelegsL %~ Set.insert stakeCred) dRepCred + _ -> id + vsDRepsL :: Lens' (VState era) (Map (Credential 'DRepRole) DRepState) vsDRepsL = lens vsDReps (\vs u -> vs {vsDReps = u}) From 5197446d078ee681df3cc2f59c368d056f2fe088 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 24 Oct 2025 18:59:50 +0100 Subject: [PATCH 13/13] Set delegators of updated pools in `PoolReap` rule in order not to lose the delegations that happened after the update, before the end of the epoch --- .../src/Cardano/Ledger/Shelley/Rules/Pool.hs | 6 +- .../Cardano/Ledger/Shelley/Rules/PoolReap.hs | 7 ++- .../Cardano/Ledger/Shelley/Imp/PoolSpec.hs | 60 ++++++++++++++++++- 3 files changed, 68 insertions(+), 5 deletions(-) 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 b3813ab8cf7..66fb6bad295 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -277,7 +277,7 @@ poolDelegationTransition = do Nothing -> Map.insert sppVrf (knownNonZeroBounded @1) Just futureStakePoolState | futureStakePoolState ^. spsVrfL /= sppVrf -> - (Map.insert sppVrf (knownNonZeroBounded @1)) + Map.insert sppVrf (knownNonZeroBounded @1) . Map.delete (futureStakePoolState ^. spsVrfL) | otherwise -> id | otherwise = id @@ -297,7 +297,9 @@ poolDelegationTransition = do let futureStakePoolState = mkStakePoolState (stakePoolState ^. spsDepositL) - (stakePoolState ^. spsDelegatorsL) + -- delegators are set in PoolReap, + -- in order to capture delegations that happened after re-registration but before the end of the epoch + mempty stakePoolParams pure $ ps 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 7b8173e496d..493ca2f7cbf 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs @@ -152,7 +152,11 @@ poolReapTransition = do -- activate future stakePools ps = ps0 - { psStakePools = Map.union (ps0 ^. psFutureStakePoolsL) (ps0 ^. psStakePoolsL) + { psStakePools = + Map.unionWith + (\newPoolState oldPoolState -> newPoolState {spsDelegators = spsDelegators oldPoolState}) + (ps0 ^. psFutureStakePoolsL) + (ps0 ^. psStakePoolsL) , psFutureStakePools = Map.empty } cs = cs0 & certPStateL .~ ps @@ -226,7 +230,6 @@ poolReapTransition = do removeVRFKeyHashOccurrence = -- Removes the key from the map if the value drops to 0 Map.update (mapNonZero (\n -> n - 1)) - delegsToClear cState pools = foldMap spsDelegators $ Map.restrictKeys (cState ^. certPStateL . psStakePoolsL) pools diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs index b9e88143506..c28a7a10e9d 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs @@ -16,7 +16,7 @@ import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure (..)) import Cardano.Ledger.State -import qualified Data.Map.Strict as Map +import Data.Map.Strict as Map import Data.Proxy import Lens.Micro import Test.Cardano.Ledger.Binary.Arbitrary (genByteString) @@ -52,6 +52,7 @@ spec = describe "POOL" $ do submitTx_ tx else submitFailingTx tx [injectFailure $ WrongNetworkPOOL (Mismatch Mainnet Testnet) kh] + it "register a pool with too big metadata" $ do pv <- getsPParams ppProtocolVersionL let maxMetadataSize = sizeHash (Proxy :: Proxy HASH) @@ -82,6 +83,39 @@ spec = describe "POOL" $ do expectPool khNew Nothing expectPool kh (Just vrf) + it "re-register a pool and change its delegations in the same epoch" $ do + (poolKh, _) <- registerNewPool + (poolKh2, _) <- registerNewPool + stakeCred <- KeyHashObj <$> freshKeyHash + _ <- registerStakeCredential stakeCred + stakeCred2 <- KeyHashObj <$> freshKeyHash + _ <- registerStakeCredential stakeCred2 + delegateStake stakeCred poolKh + vrf1 <- freshKeyHashVRF + registerPoolTx <$> poolParams poolKh vrf1 >>= \tx -> do + submitTx_ tx + expectPoolDelegs poolKh (Just [stakeCred]) + delegateStake stakeCred2 poolKh + expectPoolDelegs poolKh (Just [stakeCred, stakeCred2]) + passEpoch + expectPoolDelegs poolKh (Just [stakeCred, stakeCred2]) + + vrf2 <- freshKeyHashVRF + registerPoolTx <$> poolParams poolKh vrf2 >>= \tx -> do + submitTx_ tx + expectPoolDelegs poolKh (Just [stakeCred, stakeCred2]) + + unRegTxCert <- genUnRegTxCert stakeCred2 + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL + .~ [unRegTxCert] + expectPoolDelegs poolKh (Just [stakeCred]) + delegateStake stakeCred poolKh2 + expectPoolDelegs poolKh (Just []) + passEpoch + expectPoolDelegs poolKh (Just []) + it "re-register a pool with an already registered VRF" $ do pv <- getsPParams ppProtocolVersionL (kh1, vrf1) <- registerNewPool @@ -287,6 +321,27 @@ spec = describe "POOL" $ do expectRetiring False khNew expectPool kh Nothing + it "retiring a pool clears its delegations" $ do + (poolKh, _) <- registerNewPool + let retirement = 1 + stakeCred1 <- do + cred <- KeyHashObj <$> freshKeyHash + _ <- registerStakeCredential cred + delegateStake cred poolKh + pure cred + + retirePoolTx poolKh (EpochInterval retirement) >>= submitTx_ + expectPoolDelegs poolKh (Just [stakeCred1]) + stakeCred2 <- do + cred <- KeyHashObj <$> freshKeyHash + _ <- registerStakeCredential cred + delegateStake cred poolKh + pure cred + expectPoolDelegs poolKh (Just [stakeCred1, stakeCred2]) + + passNEpochs (fromIntegral retirement) + expectPoolDelegs poolKh Nothing + describe "Retired pools" $ do it "re-register a pool with the same keyhash and VRF " $ do (kh, vrf) <- registerNewPool @@ -331,6 +386,9 @@ spec = describe "POOL" $ do expectFuturePool poolKh mbVrf = do fps <- psFutureStakePools <$> getPState spsVrf <$> Map.lookup poolKh fps `shouldBe` mbVrf + expectPoolDelegs poolKh delegs = do + pps <- psStakePools <$> getPState + spsDelegators <$> Map.lookup poolKh pps `shouldBe` delegs expectRetiring isRetiring poolKh = do retiring <- psRetiring <$> getPState assertBool