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/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs index 2417c6fce4e..d0de945c472 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,13 +54,14 @@ import Control.State.Transition ( State, TRC (TRC), TransitionRule, + failOnJust, judgmentContext, transitionRules, (?!), ) import Data.Map (Map) import qualified Data.Map.Strict as Map -import qualified Data.Set as Set +import Data.Maybe (isJust) import Data.Void (Void) import GHC.Generics (Generic) import Lens.Micro ((^.)) @@ -150,66 +151,67 @@ conwayDelegTransition = do TRC ( ConwayDelegEnv pp pools , dState@DState {dsUnified} - , c + , cert ) <- judgmentContext - let ppKeyDeposit = pp ^. ppKeyDepositL - case c of - ConwayRegCert stakeCred sMayDeposit -> do - forM_ sMayDeposit $ checkDepositAgainstPParams ppKeyDeposit - dsUnified' <- checkAndAcceptDepositForStakeCred stakeCred ppKeyDeposit dsUnified - pure $ dState {dsUnified = dsUnified'} - ConwayUnRegCert stakeCred sMayDeposit -> do - 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 - pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified} - ConwayRegDelegCert stakeCred delegatee deposit -> do - checkStakeDelegateeRegistered pools delegatee - checkDepositAgainstPParams ppKeyDeposit deposit - dsUnified' <- checkAndAcceptDepositForStakeCred stakeCred deposit dsUnified - pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified'} - where - checkStakeDelegateeRegistered pools = + let + ppKeyDeposit = pp ^. ppKeyDepositL + checkDepositAgainstPParams deposit = + deposit == ppKeyDeposit ?! IncorrectDepositDELEG deposit + registerStakeCredential stakeCred = + let rdPair = UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError ppKeyDeposit) + in UM.insert stakeCred rdPair $ UM.RewDepUView dsUnified + 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 () - -- 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. + case cert of + ConwayRegCert stakeCred sMayDeposit -> do + forM_ sMayDeposit checkDepositAgainstPParams + checkStakeKeyNotRegistered stakeCred + pure $ dState {dsUnified = registerStakeCredential stakeCred} + ConwayUnRegCert stakeCred sMayRefund -> do + 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.UMElem (SJust rd) _ _ _ <- mUMElem + -- we return offending refund only when it doesn't match the expected one: + guard (suppliedRefund /= UM.fromCompact (UM.rdDeposit rd)) + Just suppliedRefund + checkStakeKeyHasZeroRewardBalance = do + UM.UMElem (SJust rd) _ _ _ <- mUMElem + guard (UM.rdReward rd /= mempty) + Just $ UM.fromCompact (UM.rdReward rd) + failOnJust checkInvalidRefund IncorrectDepositDELEG + isJust mUMElem ?! StakeKeyNotRegisteredDELEG stakeCred + failOnJust checkStakeKeyHasZeroRewardBalance StakeKeyHasNonZeroRewardAccountBalanceDELEG + pure $ dState {dsUnified = umap} + ConwayDelegCert stakeCred delegatee -> do + checkStakeKeyIsRegistered stakeCred + checkStakeDelegateeRegistered delegatee + pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified} + ConwayRegDelegCert stakeCred delegatee deposit -> do + checkDepositAgainstPParams deposit + checkStakeKeyNotRegistered stakeCred + checkStakeDelegateeRegistered delegatee 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 = - 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 - checkDepositAgainstPParams ppKeyDeposit deposit = - deposit == ppKeyDeposit ?! IncorrectDepositDELEG deposit - 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 = - 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) + dState + { dsUnified = processDelegation stakeCred delegatee $ registerStakeCredential stakeCred + } 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 => 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 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