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 93bf2943b47..20fa3b5e4cc 100644 --- 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 index 6b7aeecde26..94cf70a6f63 100644 --- 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 index 347ea6cdaf3..2ccc99ba8c3 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 @@ -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 index e1fda4616de..b3c0108ba80 100644 --- 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 index 9cc3310dae7..42ec72817cd 100644 --- a/libs/cardano-ledger-repl-environment/src/ReplEnvironment.hs +++ b/libs/cardano-ledger-repl-environment/src/ReplEnvironment.hs @@ -12,7 +12,10 @@ -- 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 @@ -20,7 +23,10 @@ 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