From 023eb8edf7375b99b72296eb285c6dc7ded29065 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 5 Sep 2024 18:54:23 -0600 Subject: [PATCH 01/10] Avoid passing arguments that are available in scope --- .../impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 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 2417c6fce4e..244a24977f9 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -153,10 +153,13 @@ conwayDelegTransition = do , c ) <- judgmentContext - let ppKeyDeposit = pp ^. ppKeyDepositL + let + ppKeyDeposit = pp ^. ppKeyDepositL + checkDepositAgainstPParams deposit = + deposit == ppKeyDeposit ?! IncorrectDepositDELEG deposit case c of ConwayRegCert stakeCred sMayDeposit -> do - forM_ sMayDeposit $ checkDepositAgainstPParams ppKeyDeposit + forM_ sMayDeposit checkDepositAgainstPParams dsUnified' <- checkAndAcceptDepositForStakeCred stakeCred ppKeyDeposit dsUnified pure $ dState {dsUnified = dsUnified'} ConwayUnRegCert stakeCred sMayDeposit -> do @@ -169,8 +172,8 @@ conwayDelegTransition = do checkStakeKeyIsRegistered stakeCred dsUnified pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified} ConwayRegDelegCert stakeCred delegatee deposit -> do + checkDepositAgainstPParams deposit checkStakeDelegateeRegistered pools delegatee - checkDepositAgainstPParams ppKeyDeposit deposit dsUnified' <- checkAndAcceptDepositForStakeCred stakeCred deposit dsUnified pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified'} where @@ -200,8 +203,6 @@ conwayDelegTransition = do DelegStake sPool -> delegStake stakeCred sPool dsUnified DelegVote dRep -> delegVote stakeCred dRep dsUnified DelegStakeVote sPool dRep -> delegVote stakeCred dRep $ delegStake stakeCred sPool dsUnified - checkDepositAgainstPParams ppKeyDeposit deposit = - deposit == ppKeyDeposit ?! IncorrectDepositDELEG deposit checkDepositAgainstPaidDeposit stakeCred dsUnified deposit = Just deposit == fmap (UM.fromCompact . UM.rdDeposit) (UM.lookup stakeCred $ UM.RewDepUView dsUnified) From 49b02f139d07cc4d3fac547d1ef095f556110734 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 5 Sep 2024 19:02:09 -0600 Subject: [PATCH 02/10] Further simplification of stake credential registration --- .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 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 244a24977f9..60095357e74 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -157,11 +157,18 @@ conwayDelegTransition = do ppKeyDeposit = pp ^. ppKeyDepositL checkDepositAgainstPParams deposit = deposit == ppKeyDeposit ?! IncorrectDepositDELEG deposit + registerStakeCredential stakeCred dsUnified = + -- This looks like it should have been a right-biased union, so that the (reward, deposit) pair would be inserted + -- (or overwritten) in the UMap. But since we are sure that the stake credential isn't a member yet + -- it will still work. The reason we cannot use a right-biased union here is because UMap treats deposits specially + -- in right-biased unions, and is unable to accept new deposits. + UM.RewDepUView dsUnified + UM.∪ (stakeCred, UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError ppKeyDeposit)) case c of ConwayRegCert stakeCred sMayDeposit -> do forM_ sMayDeposit checkDepositAgainstPParams - dsUnified' <- checkAndAcceptDepositForStakeCred stakeCred ppKeyDeposit dsUnified - pure $ dState {dsUnified = dsUnified'} + checkStakeKeyNotRegistered stakeCred dsUnified + pure $ dState {dsUnified = registerStakeCredential stakeCred dsUnified} ConwayUnRegCert stakeCred sMayDeposit -> do checkStakeKeyIsRegistered stakeCred dsUnified checkStakeKeyHasZeroRewardBalance stakeCred dsUnified @@ -174,8 +181,11 @@ conwayDelegTransition = do ConwayRegDelegCert stakeCred delegatee deposit -> do checkDepositAgainstPParams deposit checkStakeDelegateeRegistered pools delegatee - dsUnified' <- checkAndAcceptDepositForStakeCred stakeCred deposit dsUnified - pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified'} + checkStakeKeyNotRegistered stakeCred dsUnified + pure $ + dState + { dsUnified = processDelegation stakeCred delegatee $ registerStakeCredential stakeCred dsUnified + } where checkStakeDelegateeRegistered pools = let checkPoolRegistered targetPool = @@ -184,16 +194,6 @@ conwayDelegTransition = do DelegStake targetPool -> checkPoolRegistered targetPool DelegStakeVote targetPool _ -> checkPoolRegistered targetPool DelegVote _ -> pure () - -- Whenever we want to accept new deposit, we must always check if the stake credential isn't already registered. - checkAndAcceptDepositForStakeCred stakeCred deposit dsUnified = do - checkStakeKeyNotRegistered stakeCred dsUnified - -- This looks like it should have been a right-biased union, so that the (reward, deposit) pair would be inserted - -- (or overwritten) in the UMap. But since we are sure that the stake credential isn't a member yet - -- it will still work. The reason we cannot use a right-biased union here is because UMap treats deposits specially - -- in right-biased unions, and is unable to accept new deposits. - pure $ - UM.RewDepUView dsUnified - UM.∪ (stakeCred, UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError deposit)) delegStake stakeCred sPool dsUnified = UM.SPoolUView dsUnified UM.⨃ Map.singleton stakeCred sPool delegVote stakeCred dRep dsUnified = From f997e23d087db815ae6a58e66f7aab0f521dc880 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 5 Sep 2024 19:03:17 -0600 Subject: [PATCH 03/10] Consistent order of checks --- eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 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 60095357e74..98854dcdb0c 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -170,18 +170,18 @@ conwayDelegTransition = do checkStakeKeyNotRegistered stakeCred dsUnified pure $ dState {dsUnified = registerStakeCredential stakeCred dsUnified} ConwayUnRegCert stakeCred sMayDeposit -> do + forM_ sMayDeposit $ checkDepositAgainstPaidDeposit stakeCred dsUnified checkStakeKeyIsRegistered stakeCred dsUnified checkStakeKeyHasZeroRewardBalance stakeCred dsUnified - forM_ sMayDeposit $ checkDepositAgainstPaidDeposit stakeCred dsUnified pure $ dState {dsUnified = UM.domDeleteAll (Set.singleton stakeCred) dsUnified} ConwayDelegCert stakeCred delegatee -> do - checkStakeDelegateeRegistered pools delegatee checkStakeKeyIsRegistered stakeCred dsUnified + checkStakeDelegateeRegistered pools delegatee pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified} ConwayRegDelegCert stakeCred delegatee deposit -> do checkDepositAgainstPParams deposit - checkStakeDelegateeRegistered pools delegatee checkStakeKeyNotRegistered stakeCred dsUnified + checkStakeDelegateeRegistered pools delegatee pure $ dState { dsUnified = processDelegation stakeCred delegatee $ registerStakeCredential stakeCred dsUnified From fd9b5133f0b2aee30819143d4ad7c8567caad477 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 5 Sep 2024 19:11:50 -0600 Subject: [PATCH 04/10] Avoid complex comment by switching to `UMap.insert` --- .../impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 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 98854dcdb0c..f05f1505637 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -157,18 +157,14 @@ conwayDelegTransition = do ppKeyDeposit = pp ^. ppKeyDepositL checkDepositAgainstPParams deposit = deposit == ppKeyDeposit ?! IncorrectDepositDELEG deposit - registerStakeCredential stakeCred dsUnified = - -- This looks like it should have been a right-biased union, so that the (reward, deposit) pair would be inserted - -- (or overwritten) in the UMap. But since we are sure that the stake credential isn't a member yet - -- it will still work. The reason we cannot use a right-biased union here is because UMap treats deposits specially - -- in right-biased unions, and is unable to accept new deposits. - UM.RewDepUView dsUnified - UM.∪ (stakeCred, UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError ppKeyDeposit)) + registerStakeCredential stakeCred = + let rdPair = UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError ppKeyDeposit) + in UM.insert stakeCred rdPair $ UM.RewDepUView dsUnified case c of ConwayRegCert stakeCred sMayDeposit -> do forM_ sMayDeposit checkDepositAgainstPParams checkStakeKeyNotRegistered stakeCred dsUnified - pure $ dState {dsUnified = registerStakeCredential stakeCred dsUnified} + pure $ dState {dsUnified = registerStakeCredential stakeCred} ConwayUnRegCert stakeCred sMayDeposit -> do forM_ sMayDeposit $ checkDepositAgainstPaidDeposit stakeCred dsUnified checkStakeKeyIsRegistered stakeCred dsUnified @@ -184,7 +180,7 @@ conwayDelegTransition = do checkStakeDelegateeRegistered pools delegatee pure $ dState - { dsUnified = processDelegation stakeCred delegatee $ registerStakeCredential stakeCred dsUnified + { dsUnified = processDelegation stakeCred delegatee $ registerStakeCredential stakeCred } where checkStakeDelegateeRegistered pools = From 6f4bb37740967ad3a9b3ddb1c2a95ec1573062e4 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 5 Sep 2024 19:36:57 -0600 Subject: [PATCH 05/10] Stop checking refunds when stake credential is not registered It has been noticed that currently we report invalid refunds, even the stake credential is not registered. This makes little sense, so this commit changes this behavior. --- .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 21 ++++++++++++------- 1 file changed, 13 insertions(+), 8 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 f05f1505637..a4c246e34c1 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -20,7 +20,7 @@ module Cardano.Ledger.Conway.Rules.Deleg ( ConwayDelegEnv (..), ) where -import Cardano.Ledger.BaseTypes (ShelleyBase) +import Cardano.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..)) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) import Cardano.Ledger.Binary.Coders ( Decode (From, Invalid, SumD, Summands), @@ -43,7 +43,7 @@ import Cardano.Ledger.PoolParams (PoolParams) import Cardano.Ledger.Shelley.LedgerState (DState (..)) import qualified Cardano.Ledger.UMap as UM import Control.DeepSeq (NFData) -import Control.Monad (forM_) +import Control.Monad (forM_, guard) import Control.State.Transition ( BaseM, Environment, @@ -54,6 +54,7 @@ import Control.State.Transition ( State, TRC (TRC), TransitionRule, + failOnJust, judgmentContext, transitionRules, (?!), @@ -165,8 +166,16 @@ conwayDelegTransition = do forM_ sMayDeposit checkDepositAgainstPParams checkStakeKeyNotRegistered stakeCred dsUnified pure $ dState {dsUnified = registerStakeCredential stakeCred} - ConwayUnRegCert stakeCred sMayDeposit -> do - forM_ sMayDeposit $ checkDepositAgainstPaidDeposit stakeCred dsUnified + ConwayUnRegCert stakeCred sMayRefund -> do + let mRDPair = UM.lookup stakeCred $ UM.RewDepUView dsUnified + checkInvalidRefund = do + SJust suppliedRefund <- Just sMayRefund + -- we don't want to report invalid refund when stake credential is not registered: + UM.RDPair _ actualRefund <- mRDPair + -- we return offending refund only when it doesn't match the expected one: + guard (suppliedRefund /= UM.fromCompact actualRefund) + Just suppliedRefund + failOnJust checkInvalidRefund IncorrectDepositDELEG checkStakeKeyIsRegistered stakeCred dsUnified checkStakeKeyHasZeroRewardBalance stakeCred dsUnified pure $ dState {dsUnified = UM.domDeleteAll (Set.singleton stakeCred) dsUnified} @@ -199,10 +208,6 @@ conwayDelegTransition = do DelegStake sPool -> delegStake stakeCred sPool dsUnified DelegVote dRep -> delegVote stakeCred dRep dsUnified DelegStakeVote sPool dRep -> delegVote stakeCred dRep $ delegStake stakeCred sPool dsUnified - checkDepositAgainstPaidDeposit stakeCred dsUnified deposit = - Just deposit - == fmap (UM.fromCompact . UM.rdDeposit) (UM.lookup stakeCred $ UM.RewDepUView dsUnified) - ?! IncorrectDepositDELEG deposit checkStakeKeyNotRegistered stakeCred dsUnified = UM.notMember stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyRegisteredDELEG stakeCred checkStakeKeyIsRegistered stakeCred dsUnified = From cf46719e232c3a418604713fbb3f6181dad39220 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 5 Sep 2024 19:46:17 -0600 Subject: [PATCH 06/10] Avoid redundant lookups in the UMap for ConwayUnRegCert --- .../impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 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 a4c246e34c1..b4a97080ca7 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -61,6 +61,7 @@ import Control.State.Transition ( ) import Data.Map (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) import qualified Data.Set as Set import Data.Void (Void) import GHC.Generics (Generic) @@ -175,9 +176,13 @@ conwayDelegTransition = do -- we return offending refund only when it doesn't match the expected one: guard (suppliedRefund /= UM.fromCompact actualRefund) Just suppliedRefund + checkStakeKeyHasZeroRewardBalance = do + UM.RDPair compactReward _ <- mRDPair + guard (compactReward /= mempty) + Just $ UM.fromCompact compactReward failOnJust checkInvalidRefund IncorrectDepositDELEG - checkStakeKeyIsRegistered stakeCred dsUnified - checkStakeKeyHasZeroRewardBalance stakeCred dsUnified + isJust mRDPair ?! StakeKeyNotRegisteredDELEG stakeCred + failOnJust checkStakeKeyHasZeroRewardBalance StakeKeyHasNonZeroRewardAccountBalanceDELEG pure $ dState {dsUnified = UM.domDeleteAll (Set.singleton stakeCred) dsUnified} ConwayDelegCert stakeCred delegatee -> do checkStakeKeyIsRegistered stakeCred dsUnified @@ -212,6 +217,3 @@ conwayDelegTransition = do UM.notMember stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyRegisteredDELEG stakeCred checkStakeKeyIsRegistered stakeCred dsUnified = UM.member stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyNotRegisteredDELEG stakeCred - checkStakeKeyHasZeroRewardBalance stakeCred dsUnified = - let mReward = UM.rdReward <$> UM.lookup stakeCred (UM.RewDepUView dsUnified) - in forM_ mReward $ \r -> r == mempty ?! StakeKeyHasNonZeroRewardAccountBalanceDELEG (UM.fromCompact r) From 6f08a48dadacebfaf4d539268b30a1fdf7f9c202 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 5 Sep 2024 20:00:29 -0600 Subject: [PATCH 07/10] Move the rest of the where bindings into let * Which allows is to avoid passing redundant arguments * Switch to pointfree style and avoid using same name fo rthe umap that is being modified --- .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 55 +++++++++---------- 1 file changed, 27 insertions(+), 28 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 b4a97080ca7..d8d45a77c8c 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -152,7 +152,7 @@ conwayDelegTransition = do TRC ( ConwayDelegEnv pp pools , dState@DState {dsUnified} - , c + , cert ) <- judgmentContext let @@ -162,10 +162,30 @@ conwayDelegTransition = do registerStakeCredential stakeCred = let rdPair = UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError ppKeyDeposit) in UM.insert stakeCred rdPair $ UM.RewDepUView dsUnified - case c of + delegStake stakeCred sPool umap = + UM.SPoolUView umap UM.⨃ Map.singleton stakeCred sPool + delegVote stakeCred dRep umap = + UM.DRepUView umap UM.⨃ Map.singleton stakeCred dRep + processDelegation stakeCred delegatee = + case delegatee of + DelegStake sPool -> delegStake stakeCred sPool + DelegVote dRep -> delegVote stakeCred dRep + DelegStakeVote sPool dRep -> delegVote stakeCred dRep . delegStake stakeCred sPool + checkStakeKeyNotRegistered stakeCred = + UM.notMember stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyRegisteredDELEG stakeCred + checkStakeKeyIsRegistered stakeCred = + UM.member stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyNotRegisteredDELEG stakeCred + checkStakeDelegateeRegistered = + let checkPoolRegistered targetPool = + targetPool `Map.member` pools ?! DelegateeNotRegisteredDELEG targetPool + in \case + DelegStake targetPool -> checkPoolRegistered targetPool + DelegStakeVote targetPool _ -> checkPoolRegistered targetPool + DelegVote _ -> pure () + case cert of ConwayRegCert stakeCred sMayDeposit -> do forM_ sMayDeposit checkDepositAgainstPParams - checkStakeKeyNotRegistered stakeCred dsUnified + checkStakeKeyNotRegistered stakeCred pure $ dState {dsUnified = registerStakeCredential stakeCred} ConwayUnRegCert stakeCred sMayRefund -> do let mRDPair = UM.lookup stakeCred $ UM.RewDepUView dsUnified @@ -185,35 +205,14 @@ conwayDelegTransition = do failOnJust checkStakeKeyHasZeroRewardBalance StakeKeyHasNonZeroRewardAccountBalanceDELEG pure $ dState {dsUnified = UM.domDeleteAll (Set.singleton stakeCred) dsUnified} ConwayDelegCert stakeCred delegatee -> do - checkStakeKeyIsRegistered stakeCred dsUnified - checkStakeDelegateeRegistered pools delegatee + checkStakeKeyIsRegistered stakeCred + checkStakeDelegateeRegistered delegatee pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified} ConwayRegDelegCert stakeCred delegatee deposit -> do checkDepositAgainstPParams deposit - checkStakeKeyNotRegistered stakeCred dsUnified - checkStakeDelegateeRegistered pools delegatee + checkStakeKeyNotRegistered stakeCred + checkStakeDelegateeRegistered delegatee pure $ dState { dsUnified = processDelegation stakeCred delegatee $ registerStakeCredential stakeCred } - where - checkStakeDelegateeRegistered pools = - let checkPoolRegistered targetPool = - targetPool `Map.member` pools ?! DelegateeNotRegisteredDELEG targetPool - in \case - DelegStake targetPool -> checkPoolRegistered targetPool - DelegStakeVote targetPool _ -> checkPoolRegistered targetPool - DelegVote _ -> pure () - delegStake stakeCred sPool dsUnified = - UM.SPoolUView dsUnified UM.⨃ Map.singleton stakeCred sPool - delegVote stakeCred dRep dsUnified = - UM.DRepUView dsUnified UM.⨃ Map.singleton stakeCred dRep - processDelegation stakeCred delegatee dsUnified = - case delegatee of - DelegStake sPool -> delegStake stakeCred sPool dsUnified - DelegVote dRep -> delegVote stakeCred dRep dsUnified - DelegStakeVote sPool dRep -> delegVote stakeCred dRep $ delegStake stakeCred sPool dsUnified - checkStakeKeyNotRegistered stakeCred dsUnified = - UM.notMember stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyRegisteredDELEG stakeCred - checkStakeKeyIsRegistered stakeCred dsUnified = - UM.member stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyNotRegisteredDELEG stakeCred From c3bfd5c8e9fca29d45910be2047fc03fb9e6e196 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 5 Sep 2024 21:03:12 -0600 Subject: [PATCH 08/10] Move `committeeUpdateContainsColdCred` into let binding for consistency --- .../impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs index a7374806d88..52398a78d7c 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs @@ -217,8 +217,12 @@ conwayGovCertTransition = do failOnJust coldCredResigned ConwayCommitteeHasPreviouslyResigned let isCurrentMember = strictMaybe False (Map.member coldCred . committeeMembers) cgceCurrentCommittee + committeeUpdateContainsColdCred GovActionState {gasProposalProcedure} = + case pProcGovAction gasProposalProcedure of + UpdateCommittee _ _ newMembers _ -> Map.member coldCred newMembers + _ -> False isPotentialFutureMember = - any (committeeUpdateContainsColdCred coldCred) cgceCommitteeProposals + any committeeUpdateContainsColdCred cgceCommitteeProposals isCurrentMember || isPotentialFutureMember ?! ConwayCommitteeIsUnknown coldCred pure vState @@ -277,11 +281,6 @@ conwayGovCertTransition = do checkAndOverwriteCommitteeMemberState coldCred $ CommitteeHotCredential hotCred ConwayResignCommitteeColdKey coldCred anchor -> checkAndOverwriteCommitteeMemberState coldCred $ CommitteeMemberResigned anchor - where - committeeUpdateContainsColdCred coldCred GovActionState {gasProposalProcedure} = - case pProcGovAction gasProposalProcedure of - UpdateCommittee _ _ newMembers _ -> Map.member coldCred newMembers - _ -> False computeDRepExpiryVersioned :: ConwayEraPParams era => From 5e503c1b8e86579a87ea4e1812a7f4e7c78dba76 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 20 Sep 2024 13:22:39 -0600 Subject: [PATCH 09/10] Improve performance of `domDeleteAll` and add `extractStakingCredential` --- .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 17 ++++++----- .../src/Cardano/Ledger/UMap.hs | 28 +++++++++++++++---- 2 files changed, 30 insertions(+), 15 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 d8d45a77c8c..d0de945c472 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -62,7 +62,6 @@ import Control.State.Transition ( import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Maybe (isJust) -import qualified Data.Set as Set import Data.Void (Void) import GHC.Generics (Generic) import Lens.Micro ((^.)) @@ -188,22 +187,22 @@ conwayDelegTransition = do checkStakeKeyNotRegistered stakeCred pure $ dState {dsUnified = registerStakeCredential stakeCred} ConwayUnRegCert stakeCred sMayRefund -> do - let mRDPair = UM.lookup stakeCred $ UM.RewDepUView dsUnified + let (mUMElem, umap) = UM.extractStakingCredential stakeCred dsUnified checkInvalidRefund = do SJust suppliedRefund <- Just sMayRefund -- we don't want to report invalid refund when stake credential is not registered: - UM.RDPair _ actualRefund <- mRDPair + UM.UMElem (SJust rd) _ _ _ <- mUMElem -- we return offending refund only when it doesn't match the expected one: - guard (suppliedRefund /= UM.fromCompact actualRefund) + guard (suppliedRefund /= UM.fromCompact (UM.rdDeposit rd)) Just suppliedRefund checkStakeKeyHasZeroRewardBalance = do - UM.RDPair compactReward _ <- mRDPair - guard (compactReward /= mempty) - Just $ UM.fromCompact compactReward + UM.UMElem (SJust rd) _ _ _ <- mUMElem + guard (UM.rdReward rd /= mempty) + Just $ UM.fromCompact (UM.rdReward rd) failOnJust checkInvalidRefund IncorrectDepositDELEG - isJust mRDPair ?! StakeKeyNotRegisteredDELEG stakeCred + isJust mUMElem ?! StakeKeyNotRegisteredDELEG stakeCred failOnJust checkStakeKeyHasZeroRewardBalance StakeKeyHasNonZeroRewardAccountBalanceDELEG - pure $ dState {dsUnified = UM.domDeleteAll (Set.singleton stakeCred) dsUnified} + pure $ dState {dsUnified = umap} ConwayDelegCert stakeCred delegatee -> do checkStakeKeyIsRegistered stakeCred checkStakeDelegateeRegistered delegatee diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs index e844b7a5ecf..096a3a50eff 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs @@ -109,6 +109,8 @@ module Cardano.Ledger.UMap ( findWithDefault, size, domDeleteAll, + deleteStakingCredential, + extractStakingCredential, ) where @@ -127,7 +129,7 @@ import qualified Data.Aeson as Aeson import Data.Foldable (Foldable (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.MapExtras (intersectDomPLeft) +import Data.MapExtras as MapExtras (extract, intersectDomPLeft) import Data.Maybe as Maybe (fromMaybe, isNothing, mapMaybe) import Data.Maybe.Strict (StrictMaybe (..)) import Data.Set (Set) @@ -944,11 +946,25 @@ domDelete = (⋪) -- | Delete the stake credentials in the domain and all associated ranges from the `UMap` -- This can be expensive when there are many pointers associated with the credential. domDeleteAll :: Set (Credential 'Staking c) -> UMap c -> UMap c -domDeleteAll ks UMap {umElems, umPtrs} = - UMap - { umElems = Map.withoutKeys umElems ks - , umPtrs = Map.filter (`Set.notMember` ks) umPtrs - } +domDeleteAll ks umap = Set.foldr' deleteStakingCredential umap ks + +-- | Completely remove the staking credential from the UMap, including all associated +-- pointers. +deleteStakingCredential :: Credential 'Staking c -> UMap c -> UMap c +deleteStakingCredential cred = snd . extractStakingCredential cred + +-- | Just like `deleteStakingCredential`, but also returned the removed element. +extractStakingCredential :: Credential 'Staking c -> UMap c -> (Maybe (UMElem c), UMap c) +extractStakingCredential cred umap@UMap {umElems, umPtrs} = + case MapExtras.extract cred umElems of + (Nothing, _) -> (Nothing, umap) + (e@(Just (UMElem _ ptrs _ _)), umElems') -> + ( e + , UMap + { umElems = umElems' + , umPtrs = umPtrs `Map.withoutKeys` ptrs + } + ) -- | Delete all elements in the given `Set` from the range of the given map-like `UView`. -- This is slow for SPoolUView, RewDepUView, and DReps UViews, better hope the sets are small From 052d07325dcc4bf8a004bcad2c58d7fc7ce65d92 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 20 Sep 2024 14:18:12 -0600 Subject: [PATCH 10/10] Changelogs and version bumps --- eras/conway/impl/CHANGELOG.md | 6 +++++- eras/conway/impl/cardano-ledger-conway.cabal | 4 ++-- libs/cardano-ledger-core/CHANGELOG.md | 4 ++++ libs/cardano-ledger-core/cardano-ledger-core.cabal | 2 +- 4 files changed, 12 insertions(+), 4 deletions(-) diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 7646985014d..83125e200ec 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -1,6 +1,10 @@ # Version history for `cardano-ledger-conway` -## 1.17.0.0 +## 1.16.2.0 + +* Stop reporting `IncorrectDepositDELEG` whenever stake credential is not even registered. + +## 1.16.1.0 * Replace GOVCERT `updateDRepExpiry` with `computeDRepExpiry` * Added `Eq`, `Show`, `NFData` and `Generic` instances for `CertsEnv` diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 9434a379957..ab835b186f8 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-conway -version: 1.16.1.0 +version: 1.16.2.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK @@ -88,7 +88,7 @@ library cardano-ledger-allegra ^>=1.6, cardano-ledger-alonzo ^>=1.10, cardano-ledger-babbage ^>=1.9, - cardano-ledger-core ^>=1.14, + cardano-ledger-core ^>=1.14.1, cardano-ledger-mary ^>=1.7, cardano-ledger-shelley ^>=1.13, cardano-slotting, diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 008704a8de2..7b25ff2e462 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -1,5 +1,9 @@ # Version history for `cardano-ledger-core` +## 1.14.1.0 + +* Add `extractStakingCredential` and `deleteStakingCredential` + ## 1.14.0.0 * Add `mkTermToEvaluate` to `PlutusLanguage` class. diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 304c75e232e..6ab064bdcfb 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-core -version: 1.14.0.0 +version: 1.14.1.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK