Cardano ledger conway 1.16.2.0

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`

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:         [email protected]
 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,

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
+          }

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 =>

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.

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:         [email protected]
 author:             IOHK

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