Merge pull request #4773 from IntersectMBO/lehins/drep-undelegation

DRep undelegation fix
IntersectMBO · Nov 25, 2024 · 33e90ea · 33e90ea
2 parents 397bf8f + 33a61fe
commit 33e90ea
Show file tree

Hide file tree

Showing 5 changed files with 33 additions and 7 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
@@ -23,7 +23,7 @@ module Cardano.Ledger.Conway.Rules.Deleg (
   processDelegation,
 ) where
 
-import Cardano.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..))
+import Cardano.Ledger.BaseTypes (ProtVer (..), ShelleyBase, StrictMaybe (..), natVersion)
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders (
   Decode (From, Invalid, SumD, Summands),
@@ -174,6 +174,7 @@ conwayDelegTransition = do
     judgmentContext
   let
     ppKeyDeposit = pp ^. ppKeyDepositL
+    pv = pp ^. ppProtocolVersionL
     checkDepositAgainstPParams deposit =
       deposit == ppKeyDeposit ?! IncorrectDepositDELEG deposit
     registerStakeCredential stakeCred =
@@ -228,13 +229,14 @@ conwayDelegTransition = do
     ConwayDelegCert stakeCred delegatee -> do
       mCurDelegatee <- checkStakeKeyIsRegistered stakeCred
       checkStakeDelegateeRegistered delegatee
-      pure $ processDelegationInternal stakeCred mCurDelegatee delegatee certState
+      pure $
+        processDelegationInternal (pvMajor pv < natVersion @10) stakeCred mCurDelegatee delegatee certState
     ConwayRegDelegCert stakeCred delegatee deposit -> do
       checkDepositAgainstPParams deposit
       checkStakeKeyNotRegistered stakeCred
       checkStakeDelegateeRegistered delegatee
       pure $
-        processDelegationInternal stakeCred Nothing delegatee $
+        processDelegationInternal (pvMajor pv < natVersion @10) stakeCred Nothing delegatee $
           certState & certDStateL . dsUnifiedL .~ registerStakeCredential stakeCred
 
 -- | Apply new delegation, while properly cleaning up older delegations. This function
@@ -248,13 +250,15 @@ processDelegation ::
   CertState era
 processDelegation stakeCred newDelegatee !certState = certState'
   where
-    !certState' = processDelegationInternal stakeCred mCurDelegatee newDelegatee certState
+    !certState' = processDelegationInternal False stakeCred mCurDelegatee newDelegatee certState
     mUMElem = Map.lookup stakeCred (UM.umElems (dsUnified (certDState certState)))
     mCurDelegatee = mUMElem >>= umElemToDelegatee
 
 -- | Same as `processDelegation`, except it expects the current delegation supplied as an
 -- argument, because in ledger rules we already have it readily available.
 processDelegationInternal ::
+  -- | Preserve the buggy behavior where DRep delegations are not updated correctly (See #4772)
+  Bool ->
   -- | Delegator
   Credential 'Staking (EraCrypto era) ->
   -- | Current delegatee for the above stake credential that needs to be cleaned up.
@@ -263,7 +267,7 @@ processDelegationInternal ::
   Delegatee (EraCrypto era) ->
   CertState era ->
   CertState era
-processDelegationInternal stakeCred mCurDelegatee newDelegatee =
+processDelegationInternal preserveIncorrectDelegation stakeCred mCurDelegatee newDelegatee =
   case newDelegatee of
     DelegStake sPool -> delegStake sPool
     DelegVote dRep -> delegVote dRep
@@ -278,7 +282,9 @@ processDelegationInternal stakeCred mCurDelegatee newDelegatee =
             processDRepUnDelegation stakeCred mCurDelegatee cState
               & certDStateL . dsUnifiedL %~ \umap ->
                 UM.DRepUView umap UM.⨃ Map.singleton stakeCred dRep
-          dReps = vsDReps (certVState cState)
+          dReps
+            | preserveIncorrectDelegation = vsDReps (certVState cState)
+            | otherwise = vsDReps (certVState cState')
        in case dRep of
             DRepCredential targetDRep
               | Just dRepState <- Map.lookup targetDRep dReps ->

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs
@@ -74,7 +74,11 @@ hardforkTransition = do
         epochState
           & esLStateL . lsCertStateL %~ \certState ->
             let umap = certState ^. certDStateL . dsUnifiedL
-                dReps = certState ^. certVStateL . vsDRepsL
+                dReps =
+                  -- Reset all delegations in order to remove any inconsistencies
+                  -- Delegations will be reset accordingly below.
+                  Map.map (\dRepState -> dRepState {drepDelegs = Set.empty}) $
+                    certState ^. certVStateL . vsDRepsL
                 (dRepsWithDelegations, elemsWithoutUnknownDRepDelegations) =
                   Map.mapAccumWithKey adjustDelegations dReps (UM.umElems umap)
                 adjustDelegations ds stakeCred umElem@(UM.UMElem rd ptr stakePool mDrep) =

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
@@ -456,6 +456,11 @@ spec = do
 
       expectDelegatedVote cred (DRepCredential drepCred2)
 
+      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))
+
     it "Delegate vote and unregister stake credentials" $ do
       expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
       cred <- KeyHashObj <$> freshKeyHash

diff --git a/libs/cardano-ledger-repl-environment/cardano-ledger-repl-environment.cabal b/libs/cardano-ledger-repl-environment/cardano-ledger-repl-environment.cabal
@@ -20,6 +20,11 @@ library
         cardano-ledger-binary,
         cardano-ledger-core:{cardano-ledger-core, testlib},
         cardano-ledger-conway:{cardano-ledger-conway, testlib},
+        cardano-ledger-shelley,
+        cardano-ledger-allegra,
+        cardano-ledger-mary,
+        cardano-ledger-alonzo,
+        cardano-ledger-babbage,
         cardano-ledger-conformance,
         cardano-ledger-test,
         constrained-generators,

diff --git a/libs/cardano-ledger-repl-environment/src/ReplEnvironment.hs b/libs/cardano-ledger-repl-environment/src/ReplEnvironment.hs
@@ -12,15 +12,21 @@
 -- the REPL should load this module automatically.
 module ReplEnvironment where
 
+import Cardano.Ledger.Allegra
+import Cardano.Ledger.Alonzo
 import Cardano.Ledger.Api
+import Cardano.Ledger.Babbage
 import Cardano.Ledger.Binary
 import Cardano.Ledger.CertState
 import Cardano.Ledger.Coin
 import Cardano.Ledger.Conway
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Governance
 import Cardano.Ledger.Crypto
+import Cardano.Ledger.Mary
 import Cardano.Ledger.PoolDistr
+import Cardano.Ledger.Shelley
+import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Val
 import Test.Cardano.Ledger.Api.DebugTools