From 02571c635f52493721c76e24cad7f73987ea9d30 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Wed, 13 Sep 2023 18:12:06 +0530 Subject: [PATCH 1/3] Add vsNumDormantEpochs field to VState. This field counts the number of contiguous epochs in which the number of active governance proposals that can be voted on, remained zero. It will be incremented in every EPOCH if the number of active governance actions that can be voted on, remains zero. It will be reset when a new governance proposal is submitted successfully. --- .../src/Cardano/Ledger/CertState.hs | 18 ++++++++++++++++-- .../Test/Cardano/Ledger/Core/Arbitrary.hs | 2 +- .../src/Cardano/Ledger/Pretty.hs | 3 ++- .../Test/Cardano/Ledger/Constrained/TypeRep.hs | 7 +++++++ .../Test/Cardano/Ledger/Constrained/Vars.hs | 16 +++++++++++++--- .../Test/Cardano/Ledger/Generic/ModelState.hs | 2 +- .../Test/Cardano/Ledger/Generic/PrettyCore.hs | 3 ++- .../src/Test/Cardano/Ledger/Generic/Same.hs | 3 ++- 8 files changed, 44 insertions(+), 10 deletions(-) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs index 6405bd00543..9f696d30c7a 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs @@ -45,6 +45,7 @@ module Cardano.Ledger.CertState ( vsDRepsL, vsDRepDistrL, vsCommitteeStateL, + vsNumDormantEpochsL, csCommitteeCredsL, lookupDepositVState, ) @@ -313,6 +314,14 @@ data VState era = VState ) , vsDRepDistr :: !(DRepDistr (EraCrypto era)) , vsCommitteeState :: !(CommitteeState era) + , vsNumDormantEpochs :: EpochNo + -- ^ Number of contiguous epochs in which there are exactly zero + -- active governance proposals to vote on. It is incremented in every + -- EPOCH rule if the number of active governance proposals to vote on + -- continues to be zero. It is reset to zero when a new governance + -- action is successfully proposed. We need this counter in order to + -- bump DRep expiries through dormant periods when DReps do not have + -- an opportunity to vote on anything. } deriving (Show, Eq, Generic) @@ -321,7 +330,7 @@ lookupDepositVState :: VState era -> Credential 'DRepRole (EraCrypto era) -> May lookupDepositVState vstate = fmap drepDeposit . flip Map.lookup (vstate ^. vsDRepsL) instance Default (VState era) where - def = VState def (DRComplete Map.empty) def + def = VState def (DRComplete Map.empty) def (EpochNo 0) instance Typeable (EraCrypto era) => NoThunks (VState era) @@ -334,7 +343,8 @@ instance Era era => DecShareCBOR (VState era) where RecD VState DecCBOR (VState era) where decCBOR = decNoShareCBOR @@ -346,6 +356,7 @@ instance Era era => EncCBOR (VState era) where !> To vsDReps !> To vsDRepDistr !> To vsCommitteeState + !> To vsNumDormantEpochs -- | The state associated with the DELPL rule, which combines the DELEG rule -- and the POOL rule. @@ -534,6 +545,9 @@ vsDRepDistrL = lens vsDRepDistr (\vs u -> vs {vsDRepDistr = u}) vsCommitteeStateL :: Lens' (VState era) (CommitteeState era) vsCommitteeStateL = lens vsCommitteeState (\vs u -> vs {vsCommitteeState = u}) +vsNumDormantEpochsL :: Lens' (VState era) EpochNo +vsNumDormantEpochsL = lens vsNumDormantEpochs (\vs u -> vs {vsNumDormantEpochs = u}) + csCommitteeCredsL :: Lens' (CommitteeState era) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs index dc4b3b1790d..3bdd96b7c6c 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs @@ -696,7 +696,7 @@ instance Crypto c => Arbitrary (Anchor c) where deriving instance Era era => Arbitrary (CommitteeState era) instance Era era => Arbitrary (VState era) where - arbitrary = VState <$> arbitrary <*> (DRComplete <$> arbitrary) <*> arbitrary + arbitrary = VState <$> arbitrary <*> (DRComplete <$> arbitrary) <*> arbitrary <*> arbitrary instance Crypto c => Arbitrary (InstantaneousRewards c) where arbitrary = InstantaneousRewards <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary diff --git a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs index 79f996a2027..3d9227854a3 100644 --- a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs +++ b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs @@ -1698,12 +1698,13 @@ instance PrettyA (DRepState c) where deriving instance PrettyA (CommitteeState era) instance PrettyA (VState era) where - prettyA (VState vsDReps vsDRepDistr vsCommitteeHotKeys) = + prettyA (VState vsDReps vsDRepDistr vsCommitteeHotKeys vsNumDormantEpochs) = ppRecord "VState" [ ("DReps", prettyA vsDReps) , ("DResDistr", ppMap prettyA (ppCoin . fromCompact) (extractDRepDistr vsDRepDistr)) , ("CC Hot Keys", prettyA vsCommitteeHotKeys) + , ("Number of dormant epochs", prettyA vsNumDormantEpochs) ] -- ====================================================== diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs index 8117e63dd81..23690478c8f 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/TypeRep.hs @@ -306,6 +306,7 @@ data Rep era t where PrevHardForkR :: Era era => Rep era (PrevGovActionId 'HardForkPurpose (EraCrypto era)) PrevCommitteeR :: Era era => Rep era (PrevGovActionId 'CommitteePurpose (EraCrypto era)) PrevConstitutionR :: Era era => Rep era (PrevGovActionId 'ConstitutionPurpose (EraCrypto era)) + NumDormantEpochsR :: Era era => Rep era EpochNo stringR :: Rep era String stringR = ListR CharR @@ -319,6 +320,7 @@ data IsTypeable a where repTypeable :: Rep era t -> IsTypeable t repTypeable r = case r of DRepStateR -> IsTypeable + NumDormantEpochsR -> IsTypeable CommColdCredR -> IsTypeable CommHotCredR -> IsTypeable GovActionR -> IsTypeable @@ -547,6 +549,7 @@ synopsis PrevPParamUpdateR (PrevGovActionId x) = synopsis @e GovActionIdR x synopsis PrevHardForkR (PrevGovActionId x) = synopsis @e GovActionIdR x synopsis PrevCommitteeR (PrevGovActionId x) = synopsis @e GovActionIdR x synopsis PrevConstitutionR (PrevGovActionId x) = synopsis @e GovActionIdR x +synopsis NumDormantEpochsR x = show x synSum :: Rep era a -> a -> String synSum (MapR _ CoinR) m = ", sum = " ++ show (pcCoin (Map.foldl' (<>) mempty m)) @@ -679,6 +682,7 @@ instance Shaped (Rep era) any where shape PrevHardForkR = Nullary 97 shape PrevCommitteeR = Nullary 98 shape PrevConstitutionR = Nullary 99 + shape NumDormantEpochsR = Nullary 101 compareRep :: forall era t s. Rep era t -> Rep era s -> Ordering compareRep = cmpIndex @(Rep era) @@ -856,6 +860,7 @@ genSizedRep _ PrevPParamUpdateR = arbitrary genSizedRep _ PrevHardForkR = arbitrary genSizedRep _ PrevCommitteeR = arbitrary genSizedRep _ PrevConstitutionR = arbitrary +genSizedRep _ NumDormantEpochsR = arbitrary genRep :: forall era b. @@ -999,6 +1004,7 @@ shrinkRep PrevPParamUpdateR x = shrink x shrinkRep PrevHardForkR x = shrink x shrinkRep PrevCommitteeR x = shrink x shrinkRep PrevConstitutionR x = shrink x +shrinkRep NumDormantEpochsR _ = [] -- =========================== @@ -1122,6 +1128,7 @@ hasOrd rep xx = explain ("'hasOrd " ++ show rep ++ "' fails") (help rep xx) help PrevHardForkR _ = failT ["PrevGovActionId 'HardFork, does not have an Ord instance"] help PrevCommitteeR _ = failT ["PrevGovActionId 'Committee, does not have an Ord instance"] help PrevConstitutionR _ = failT ["PrevGovActionId 'Constitution, does not have an Ord instance"] + help NumDormantEpochsR v = pure $ With v hasEq :: Rep era t -> s t -> Typed (HasConstraint Eq (s t)) hasEq rep xx = explain ("'hasOrd " ++ show rep ++ "' fails") (help rep xx) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs index 6756671c711..e2f91a42c7c 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs @@ -19,7 +19,7 @@ import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded (..)) import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) import Cardano.Ledger.BaseTypes (BlocksMade (..), EpochNo, Network (..), ProtVer (..), SlotNo (..), StrictMaybe (..), UnitInterval) import qualified Cardano.Ledger.BaseTypes as Base (Globals (..)) -import Cardano.Ledger.CertState (CommitteeState (..), csCommitteeCredsL) +import Cardano.Ledger.CertState (CommitteeState (..), csCommitteeCredsL, vsNumDormantEpochsL) import Cardano.Ledger.Coin (Coin (..), DeltaCoin) import Cardano.Ledger.Conway.Governance hiding (GovState) import Cardano.Ledger.Core ( @@ -282,6 +282,12 @@ committeeState = Var $ V "committeeState" (MapR CommColdCredR (MaybeR CommHotCre committeeStateL :: NELens era (Map (Credential 'ColdCommitteeRole (EraCrypto era)) (Maybe (Credential 'HotCommitteeRole (EraCrypto era)))) committeeStateL = nesEsL . esLStateL . lsCertStateL . certVStateL . vsCommitteeStateL . csCommitteeCredsL +numDormantEpochs :: Era era => Term era EpochNo +numDormantEpochs = Var $ V "numDormantEpochs" NumDormantEpochsR (Yes NewEpochStateR numDormantEpochsL) + +numDormantEpochsL :: NELens era EpochNo +numDormantEpochsL = nesEsL . esLStateL . lsCertStateL . certVStateL . vsNumDormantEpochsL + -- UTxOState utxo :: Era era => Proof era -> Term era (Map (TxIn (EraCrypto era)) (TxOutF era)) @@ -911,9 +917,13 @@ certstateT = -- | Target for VState vstateT :: forall era. Era era => RootTarget era (VState era) (VState era) -vstateT = Invert "VState" (typeRep @(VState era)) vStateF :$ Lensed dreps vsDRepsL :$ Lensed committeeState (vsCommitteeStateL . csCommitteeCredsL) +vstateT = + Invert "VState" (typeRep @(VState era)) vStateF + :$ Lensed dreps vsDRepsL + :$ Lensed committeeState (vsCommitteeStateL . csCommitteeCredsL) + :$ Lensed numDormantEpochs vsNumDormantEpochsL where - vStateF x z = VState x (DRComplete Map.empty) (CommitteeState z) + vStateF x y z = VState x (DRComplete Map.empty) (CommitteeState y) z -- | Target for PState pstateT :: forall era. Era era => RootTarget era (PState era) (PState era) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs index 6a627f67f7a..7c2dbccfc88 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs @@ -338,7 +338,7 @@ instance Extract (PState era) era where extract x = PState (mPoolParams x) (mFPoolParams x) (mRetiring x) Map.empty instance Extract (VState era) era where - extract _ = VState def (DRComplete Map.empty) def + extract _ = VState def (DRComplete Map.empty) def (EpochNo 0) instance Extract (CertState era) era where extract x = CertState (extract x) (extract x) (extract x) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs index 82762d315fe..ba372e39670 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs @@ -1801,12 +1801,13 @@ pcCertState (CertState vst pst dst) = ] pcVState :: VState era -> PDoc -pcVState (VState dreps drepDistr (CommitteeState committeeHotCreds)) = +pcVState (VState dreps drepDistr (CommitteeState committeeHotCreds) numDormantEpochs) = ppRecord "VState" [ ("DReps", ppMap pcCredential pcDRepState dreps) , ("DResDistr", ppMap pcDRep (pcCoin . fromCompact) (extractDRepDistr drepDistr)) , ("CC Hot Keys", ppMap pcCredential (ppMaybe pcCredential) committeeHotCreds) + , ("Number of dormant epochs", ppEpochNo numDormantEpochs) ] pcAnchor :: Anchor c -> PDoc diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs index 317bad18823..a0a69eed1ef 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs @@ -144,10 +144,11 @@ instance Same era (DState era) where ] instance Same era (VState era) where - same _proof (VState dr1 dist1 cchk1) (VState dr2 dist2 cchk2) = + same _proof (VState dr1 dist1 cchk1 numDE1) (VState dr2 dist2 cchk2 numDE2) = [ ("DReps", eqByShow dr1 dr2) , ("DRepDistr", eqByShow (extractDRepDistr dist1) (extractDRepDistr dist2)) , ("CC Hot Keys", eqByShow cchk1 cchk2) + , ("Num Dormant Epochs", eqByShow numDE1 numDE2) ] sameUTxO :: Proof era -> UTxO era -> UTxO era -> Maybe PDoc From 9fb1af88ecd9b5415a4856b26401d56c8724c661 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Fri, 15 Sep 2023 15:50:12 +0530 Subject: [PATCH 2/3] Prevent DRep expiry when no proposals to vote on. In EPOCH, we make sure to update the dormant-epochs counter every time we see that the previous epoch didn't have any governance proposals to vote on. When there is a new governance proposal in a transaction AND the dormant-epochs counter is greater than zero, we 1. Update the expiry for all DReps by adding the counter 2. Reset the dormant-epochs counter We update Api.State.Query.queryDRepState to report the effective DRep expiry information. Add snapshotsGovStateL to ConwayEraGov Move asks out of loop in GOV Update changelogs and bump packages --- .../allegra/impl/cardano-ledger-allegra.cabal | 2 +- eras/alonzo/impl/cardano-ledger-alonzo.cabal | 2 +- .../cardano-ledger-alonzo-test.cabal | 2 +- .../babbage/impl/cardano-ledger-babbage.cabal | 2 +- .../cardano-ledger-babbage-test.cabal | 2 +- eras/conway/impl/CHANGELOG.md | 3 ++ eras/conway/impl/cardano-ledger-conway.cabal | 2 +- .../src/Cardano/Ledger/Conway/Governance.hs | 2 ++ .../src/Cardano/Ledger/Conway/Rules/Certs.hs | 35 +++++++++++++++---- .../src/Cardano/Ledger/Conway/Rules/Epoch.hs | 29 +++++++++++---- .../src/Cardano/Ledger/Conway/Rules/Gov.hs | 2 +- .../cardano-ledger-conway-test.cabal | 2 +- eras/mary/impl/cardano-ledger-mary.cabal | 2 +- .../shelley/impl/cardano-ledger-shelley.cabal | 2 +- .../Shelley/Serialisation/Golden/Encoding.hs | 29 +++++++-------- libs/cardano-ledger-api/CHANGELOG.md | 2 ++ .../cardano-ledger-api.cabal | 2 +- .../src/Cardano/Ledger/Api/State/Query.hs | 9 +++-- libs/cardano-ledger-core/CHANGELOG.md | 3 +- .../cardano-ledger-core.cabal | 2 +- .../cardano-ledger-pretty.cabal | 2 +- .../Cardano/Ledger/Constrained/Examples.hs | 1 + .../Ledger/Constrained/Preds/CertState.hs | 1 + 23 files changed, 94 insertions(+), 46 deletions(-) diff --git a/eras/allegra/impl/cardano-ledger-allegra.cabal b/eras/allegra/impl/cardano-ledger-allegra.cabal index 89369f71447..a3cb783ee97 100644 --- a/eras/allegra/impl/cardano-ledger-allegra.cabal +++ b/eras/allegra/impl/cardano-ledger-allegra.cabal @@ -52,7 +52,7 @@ library bytestring, cardano-crypto-class, cardano-ledger-binary >=1.0, - cardano-ledger-core >=1.6.1 && <1.7, + cardano-ledger-core >=1.6.1 && <1.8, cardano-ledger-shelley >=1.6.1 && <1.7, cardano-strict-containers, cardano-slotting, diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 7df0b0bf1e4..6aa0331d34f 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -67,7 +67,7 @@ library cardano-ledger-allegra >=1.1, cardano-crypto-class, cardano-ledger-binary >=1.0.1, - cardano-ledger-core >=1.6.1 && <1.7, + cardano-ledger-core >=1.6.1 && <1.8, cardano-ledger-mary >=1.1, cardano-ledger-shelley ^>=1.6.1, cardano-slotting, diff --git a/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal b/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal index f1dec523c99..c0fd8859026 100644 --- a/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal +++ b/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal @@ -51,7 +51,7 @@ library bytestring, cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.4, cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.0, - cardano-ledger-core:{cardano-ledger-core, testlib} >=1.5 && <1.7, + cardano-ledger-core:{cardano-ledger-core, testlib} >=1.5 && <1.8, cardano-ledger-pretty, cardano-ledger-allegra ^>=1.2, cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.6 && <1.7, diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index cf506fab5b8..b32a8241d55 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -62,7 +62,7 @@ library cardano-ledger-allegra >=1.1, cardano-ledger-alonzo ^>=1.4.2, cardano-ledger-binary >=1.0, - cardano-ledger-core >=1.6.1 && <1.7, + cardano-ledger-core >=1.6.1 && <1.8, cardano-ledger-mary >=1.1, cardano-ledger-shelley ^>=1.6, cardano-slotting, diff --git a/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal b/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal index 85f56c6d312..fa163c491b3 100644 --- a/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal +++ b/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal @@ -41,7 +41,7 @@ library cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.3 && <1.5, cardano-ledger-alonzo-test >=1.1, cardano-ledger-babbage:{cardano-ledger-babbage, testlib} ^>=1.4, - cardano-ledger-core:{cardano-ledger-core, testlib} >=1.3 && <1.7, + cardano-ledger-core:{cardano-ledger-core, testlib} >=1.3 && <1.8, cardano-ledger-shelley-ma-test >=1.1, cardano-ledger-mary ^>=1.3, cardano-ledger-shelley-test >=1.1, diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 8905e4acdab..925b25f5479 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,9 @@ ## 1.9.0.0 +* Prevent `DRep` expiry when there are no active governance proposals to vote on (in ConwayCERTS). #3729 + * Add `updateNumDormantEpochs` function in `ConwayEPOCH` to update the dormant-epochs counter + * Refactor access to `ConwayGovState` by making its lens part of `ConwayEraGov`. * Add `ExpirationEpochTooSmall` data constructor to `ConwayGovPredFailure` * Add `ConflictingCommitteeUpdate` data constructor to `ConwayGovPredFailure` * Rename `NewCommitte` to `UpdateCommittee` diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 5dae2fd4741..2bebfb3a1f4 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -73,7 +73,7 @@ library cardano-ledger-allegra >=1.1, cardano-ledger-alonzo ^>=1.4.2, cardano-ledger-babbage >=1.4.1, - cardano-ledger-core ^>=1.6.1, + cardano-ledger-core ^>=1.7, cardano-ledger-mary >=1.1, cardano-ledger-shelley ^>=1.6.1, cardano-slotting, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index d3cfd98deef..d45d367eb46 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -552,9 +552,11 @@ instance EraPParams (ConwayEra c) => EraGov (ConwayEra c) where class EraGov era => ConwayEraGov era where constitutionGovStateL :: Lens' (GovState era) (Constitution era) + snapshotsGovStateL :: Lens' (GovState era) (GovSnapshots era) instance Crypto c => ConwayEraGov (ConwayEra c) where constitutionGovStateL = cgEnactStateL . ensConstitutionL + snapshotsGovStateL = cgGovSnapshotsL pparamsUpdateThreshold :: forall era. diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs index 1723f6ae16a..1a89bfd809e 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs @@ -32,7 +32,7 @@ import Cardano.Ledger.Binary.Coders ( (!>), ( do - -- Update DRep expiry for all DReps that are voting in this transaction + -- If there is a new governance proposal to vote on in this transaction, + -- AND the number of dormant-epochs recorded is greater than zero, we bump + -- the expiry for all DReps by the number of dormant epochs, and reset the + -- counter to zero. + -- It does not matter that this rule (CERTS) is called _before_ the GOV rule + -- in LEDGER, even though we cannot validate any governance proposal here, + -- since the entire transaction will fail if the proposal is not accepted in + -- GOV, and so will this expiry bump done here. It will be discarded. + let certState' = + let hasProposals = not . SSeq.null $ tx ^. bodyTxL . proposalProceduresTxBodyL + numDormantEpochs = certState ^. certVStateL . vsNumDormantEpochsL + isNumDormantEpochsNonZero = numDormantEpochs /= 0 + in if hasProposals && isNumDormantEpochsNonZero + then + certState + & certVStateL . vsDRepsL %~ (<&> (drepExpiryL %~ (+ numDormantEpochs))) + & certVStateL . vsNumDormantEpochsL .~ 0 + else certState + + -- Update DRep expiry for all DReps that are voting in this transaction. + -- This will execute in mutual-exclusion to the previous updates to DRep expiry, + -- because if there are no proposals to vote on , there will be no votes either. let drepActivity = pp ^. ppDRepActivityL updatedVSDReps = Map.foldlWithKey' @@ -184,14 +206,15 @@ conwayCertsTransition = do DRepVoter cred -> Map.adjust (drepExpiryL .~ currentEpoch + drepActivity) cred dreps _ -> dreps ) - (certState ^. certVStateL . vsDRepsL) + (certState' ^. certVStateL . vsDRepsL) (unVotingProcedures $ tx ^. bodyTxL . votingProceduresTxBodyL) - certStateWithDRepExpiryUpdated = certState & certVStateL . vsDRepsL .~ updatedVSDReps + certStateWithDRepExpiryUpdated = certState' & certVStateL . vsDRepsL .~ updatedVSDReps dState = certStateWithDRepExpiryUpdated ^. certDStateL withdrawals = tx ^. bodyTxL . withdrawalsTxBodyL + -- Validate withdrawals and rewards and drain withdrawals - validateTrans WithdrawalsNotInRewardsCERTS $ - validateZeroRewards dState withdrawals network + validateTrans WithdrawalsNotInRewardsCERTS $ validateZeroRewards dState withdrawals network + pure $ certStateWithDRepExpiryUpdated & certDStateL .~ drainWithdrawals dState withdrawals gamma :|> c -> do certState' <- diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs index 8eec1ecd25d..c9dd9f50633 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs @@ -31,6 +31,7 @@ import Cardano.Ledger.CertState ( dsUnifiedL, vsCommitteeStateL, vsDRepsL, + vsNumDormantEpochsL, ) import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Compactible (Compactible (..)) @@ -38,6 +39,7 @@ import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Era (ConwayEPOCH, ConwayRATIFY) import Cardano.Ledger.Conway.Governance ( Committee, + ConwayEraGov, ConwayGovState (..), GovActionState (..), GovSnapshots (..), @@ -46,7 +48,10 @@ import Cardano.Ledger.Conway.Governance ( cgGovSnapshotsL, curGovSnapshotsL, ensCommitteeL, + prevGovSnapshotsL, snapshotActions, + snapshotIds, + snapshotsGovStateL, ) import Cardano.Ledger.Conway.Governance.Procedures (Committee (..)) import Cardano.Ledger.Conway.Governance.Snapshots (snapshotLookupId, snapshotRemoveIds) @@ -112,7 +117,7 @@ import Data.Sequence.Strict (StrictSeq (..)) import qualified Data.Sequence.Strict as Seq import qualified Data.Set as Set import Data.Void (Void, absurd) -import Lens.Micro (Lens', (%~), (&), (.~), (<>~), (^.)) +import Lens.Micro (Lens', (%~), (&), (+~), (.~), (<>~), (^.)) data ConwayEpochEvent era = PoolReapEvent (Event (EraRule "POOLREAP" era)) @@ -120,7 +125,7 @@ data ConwayEpochEvent era instance ( EraTxOut era - , EraGov era + , ConwayEraGov era , Embed (EraRule "SNAP" era) (ConwayEPOCH era) , Environment (EraRule "SNAP" era) ~ SnapEnv era , State (EraRule "SNAP" era) ~ SnapShots (EraCrypto era) @@ -173,6 +178,15 @@ returnProposalDeposits removedProposals = where updateUMap = returnProposalDepositsUMap removedProposals +-- | When there have been zero governance proposals to vote on in the previous epoch +-- increase the dormant-epoch counter by one. +updateNumDormantEpochs :: ConwayEraGov era => LedgerState era -> LedgerState era +updateNumDormantEpochs ls = + let wasPrevEpochDormant = Seq.null . snapshotIds $ ls ^. lsUTxOStateL . utxosGovStateL . snapshotsGovStateL . prevGovSnapshotsL + in if wasPrevEpochDormant + then ls & lsCertStateL . certVStateL . vsNumDormantEpochsL +~ 1 + else ls + epochTransition :: forall era. ( Embed (EraRule "SNAP" era) (ConwayEPOCH era) @@ -188,7 +202,7 @@ epochTransition :: , State (EraRule "RATIFY" era) ~ RatifyState era , GovState era ~ ConwayGovState era , Signal (EraRule "RATIFY" era) ~ RatifySignal era - , EraGov era + , ConwayEraGov era ) => TransitionRule (ConwayEPOCH era) epochTransition = do @@ -197,15 +211,16 @@ epochTransition = do , es@EpochState { esAccountState = acnt , esSnapshots = ss - , esLState = ls + , esLState = ledgerState , esNonMyopic = nm } , eNo ) <- judgmentContext - let pp = es ^. curPParamsEpochStateL - let utxoSt = lsUTxOState ls - let CertState vstate pstate dstate = lsCertState ls + let ls = updateNumDormantEpochs ledgerState + pp = es ^. curPParamsEpochStateL + utxoSt = lsUTxOState ls + CertState vstate pstate dstate = lsCertState ls ss' <- trans @(EraRule "SNAP" era) $ TRC (SnapEnv ls pp, ss, ()) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs index 7e52757c7dc..3ba78f9246a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs @@ -249,6 +249,7 @@ govTransition :: TransitionRule (ConwayGOV era) govTransition = do TRC (GovEnv txid currentEpoch pp, st, gp) <- judgmentContext + expectedNetworkId <- liftSTS $ asks networkId let applyProps st' Empty = pure st' applyProps st' ((idx, ProposalProcedure {..}) :<| ps) = do @@ -259,7 +260,6 @@ govTransition = do runTest $ actionWellFormed pProcGovAction - expectedNetworkId <- liftSTS $ asks networkId getRwdNetwork pProcReturnAddr == expectedNetworkId ?! ProposalProcedureNetworkIdMismatch pProcReturnAddr expectedNetworkId diff --git a/eras/conway/test-suite/cardano-ledger-conway-test.cabal b/eras/conway/test-suite/cardano-ledger-conway-test.cabal index bfa654eb757..5c83c9a7f40 100644 --- a/eras/conway/test-suite/cardano-ledger-conway-test.cabal +++ b/eras/conway/test-suite/cardano-ledger-conway-test.cabal @@ -43,7 +43,7 @@ library cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.0, cardano-strict-containers, cardano-ledger-conway:{cardano-ledger-conway, testlib} >=1.9 && <1.10, - cardano-ledger-core:{cardano-ledger-core, testlib} >=1.3 && <1.7, + cardano-ledger-core:{cardano-ledger-core, testlib} >=1.3 && <1.8, cardano-ledger-allegra ^>=1.2, cardano-ledger-mary ^>=1.3, cardano-ledger-shelley-ma-test >=1.1, diff --git a/eras/mary/impl/cardano-ledger-mary.cabal b/eras/mary/impl/cardano-ledger-mary.cabal index 2c37b96ec42..163f5e07bce 100644 --- a/eras/mary/impl/cardano-ledger-mary.cabal +++ b/eras/mary/impl/cardano-ledger-mary.cabal @@ -59,7 +59,7 @@ library cardano-data, cardano-ledger-allegra >=1.1, cardano-ledger-binary >=1.0, - cardano-ledger-core >=1.6.1 && <1.7, + cardano-ledger-core >=1.6.1 && <1.8, cardano-ledger-shelley >=1.6.1 && <1.7, containers, deepseq, diff --git a/eras/shelley/impl/cardano-ledger-shelley.cabal b/eras/shelley/impl/cardano-ledger-shelley.cabal index d4529989c47..cbd9783adf0 100644 --- a/eras/shelley/impl/cardano-ledger-shelley.cabal +++ b/eras/shelley/impl/cardano-ledger-shelley.cabal @@ -105,7 +105,7 @@ library cardano-data >=1.0, cardano-ledger-binary >=1.0, cardano-ledger-byron, - cardano-ledger-core >=1.6.1 && <1.7, + cardano-ledger-core >=1.6.1 && <1.8, cardano-slotting, vector-map >=1.0, containers, diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs index b5956cf9605..854019dfa17 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs @@ -1138,23 +1138,18 @@ tests = actualHex = B16.encode actual expectedHex = mconcat - [ "8700a1581ce0a714319812c3f773ba04ec5d6b3ffcd5aad85" - , "006805b047b0825410aa1581ca646474b8f5431261506b6c2" - , "73d307c7569a4eb6c96b42dd4a29520a0384821927101903e" - , "8828383a081a0a084a0a0a0a08482a0a0a0a084a0a0000086" - , "a1825820ee155ace9c40292074cb6aff8c9ccdd273c81648f" - , "f1149ef36bcea6ebb8a3e250082583900cb9358529df4729c" - , "3246a2a033cb9821abbfd16de4888005904abc410d6a577e9" - , "441ad8ed9663931906e4d43ece8f82c712b1d0235affb060a" - , "1903e80184a0a092000000190800000000001864d81e82000" - , "1d81e820001d81e820001d81e820001810002000100920000" - , "00190800000000001864d81e820001d81e820001d81e82000" - , "1d81e82000181000200000082a0a0008483a0a0a083a0a0a0" - , "83a0a0a00082a000818300880082020082a000000000a0a08" - , "40185a0803903ba820200a0a082a0a0a1581ce0a714319812" - , "c3f773ba04ec5d6b3ffcd5aad85006805b047b08254182820" - , "1015820c5e21ab1c9f6022d81c3b25e3436cb7f1df77f9652" - , "ae3e1310c28e621dd87b4ca0" + [ "8700a1581ce0a714319812c3f773ba04ec5d6b3ffcd5aad85006805b047b0825410aa158" + , "1ca646474b8f5431261506b6c273d307c7569a4eb6c96b42dd4a29520a03848219271019" + , "03e8828384a081a0a00084a0a0a0a08482a0a0a0a084a0a0000086a1825820ee155ace9c" + , "40292074cb6aff8c9ccdd273c81648ff1149ef36bcea6ebb8a3e250082583900cb935852" + , "9df4729c3246a2a033cb9821abbfd16de4888005904abc410d6a577e9441ad8ed9663931" + , "906e4d43ece8f82c712b1d0235affb060a1903e80184a0a0920000001908000000000018" + , "64d81e820001d81e820001d81e820001d81e820001810002000100920000001908000000" + , "00001864d81e820001d81e820001d81e820001d81e82000181000200000082a0a0008483" + , "a0a0a083a0a0a083a0a0a00082a000818300880082020082a000000000a0a0840185a080" + , "3903ba820200a0a082a0a0a1581ce0a714319812c3f773ba04ec5d6b3ffcd5aad8500680" + , "5b047b082541828201015820c5e21ab1c9f6022d81c3b25e3436cb7f1df77f9652ae3e13" + , "10c28e621dd87b4ca0" ] in testCase "ledger state golden test" $ unless (actual == expected) $ diff --git a/libs/cardano-ledger-api/CHANGELOG.md b/libs/cardano-ledger-api/CHANGELOG.md index 0ae60f26341..5a7ba677c15 100644 --- a/libs/cardano-ledger-api/CHANGELOG.md +++ b/libs/cardano-ledger-api/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.6.0.0 +* Add the dormant-epochs counter to `DRep` expiry in `queryDRepState` #3729 + * If it is not zero. * Rename: * `GovActionsState` to `GovSnapshots` * `cgGovActionsStateL` to `cgGovSnapshotsL` diff --git a/libs/cardano-ledger-api/cardano-ledger-api.cabal b/libs/cardano-ledger-api/cardano-ledger-api.cabal index b15482479e4..33fcc08a928 100644 --- a/libs/cardano-ledger-api/cardano-ledger-api.cabal +++ b/libs/cardano-ledger-api/cardano-ledger-api.cabal @@ -54,7 +54,7 @@ library cardano-ledger-babbage >=1.1, cardano-ledger-binary >=1.0, cardano-ledger-conway >=1.7, - cardano-ledger-core >=1.5 && <1.7, + cardano-ledger-core ^>=1.7, cardano-ledger-mary >=1.1, cardano-ledger-shelley ^>=1.6, cardano-slotting, diff --git a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/State/Query.hs b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/State/Query.hs index 2a326b497a2..d42e4dd7673 100644 --- a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/State/Query.hs +++ b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/State/Query.hs @@ -31,7 +31,7 @@ import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Compactible (fromCompact) import Cardano.Ledger.Core import Cardano.Ledger.Credential (Credential) -import Cardano.Ledger.DRepDistr (extractDRepDistr) +import Cardano.Ledger.DRepDistr (drepExpiryL, extractDRepDistr) import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) import Cardano.Ledger.SafeHash (SafeHash) import Cardano.Ledger.Shelley.Governance (EraGov (GovState, getConstitution)) @@ -93,9 +93,14 @@ queryDRepState :: Map (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)) queryDRepState nes creds | null creds = drepsState - | otherwise = drepsState `Map.restrictKeys` creds + | otherwise = + drepsState `Map.restrictKeys` creds + & if numDormantEpochs == 0 + then id + else (<&> drepExpiryL %~ (+ numDormantEpochs)) where drepsState = vsDReps $ certVState $ lsCertState $ esLState $ nesEs nes + numDormantEpochs = vsNumDormantEpochs $ certVState $ lsCertState $ esLState $ nesEs nes -- | Query DRep stake distribution. Note that this can be an expensive query because there -- is a chance that current distribution has not been fully computed yet. diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index b9ce1a5efc5..c9ae4a058d4 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -1,7 +1,8 @@ # Version history for `cardano-ledger-core` -## 1.6.1.0 +## 1.7.0.0 +* Add `vsNumDormantEpochs` to `VState` to track the number of contiguous epochs in which there were no governance proposals to vote on. #3729 * Add `fromEraShareCBOR` * Remove redundant `DecCBOR` constraint in `eraDecoder` * Add `FromJSON` instance to `Anchor` diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index b1606e1be4f..9f06c75a3b8 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.6.1.0 +version: 1.7.0.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK diff --git a/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal b/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal index 85c553c2936..1e2ff6cbafc 100644 --- a/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal +++ b/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal @@ -40,7 +40,7 @@ library cardano-ledger-babbage >=1.1, cardano-ledger-byron, cardano-ledger-conway ^>=1.9, - cardano-ledger-core ^>=1.6, + cardano-ledger-core >=1.6, cardano-ledger-mary >=1.0, cardano-ledger-shelley ^>=1.6, cardano-protocol-tpraos >=1.0, diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Examples.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Examples.hs index 80e583fe954..39319e625a5 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Examples.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Examples.hs @@ -580,6 +580,7 @@ dstatePreds _p = , Dom delegations :⊆: Dom rewards , Random dreps , Random committeeState + , Random numDormantEpochs , Dom rewards :=: Rng ptrs , -- This implies (Fixed (ExactSize 3) instanReserves) -- But it also implies that the new introduced variable instanReservesDom also has size 3 diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/CertState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/CertState.hs index 6c248c89768..6eaf2fa14a1 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/CertState.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/CertState.hs @@ -55,6 +55,7 @@ vstatePreds _p = , Sized (Range 5 7) (Dom committeeState) , Subset (Dom dreps) voteUniv , Subset (Dom committeeState) voteCredUniv + , Random numDormantEpochs ] vstateStage :: From 1b845d1d5d8e449df92201d92753c1be0764f7cb Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Tue, 19 Sep 2023 19:03:35 +0530 Subject: [PATCH 3/3] Add ConwayFeatures test for preventing drep expiry --- eras/conway/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Conway/Governance.hs | 2 + .../Ledger/Conway/Governance/Procedures.hs | 4 + .../Cardano/Ledger/Examples/ConwayFeatures.hs | 149 ++++++++++++++++-- 4 files changed, 147 insertions(+), 9 deletions(-) diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 925b25f5479..fa805902447 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -5,6 +5,7 @@ * Prevent `DRep` expiry when there are no active governance proposals to vote on (in ConwayCERTS). #3729 * Add `updateNumDormantEpochs` function in `ConwayEPOCH` to update the dormant-epochs counter * Refactor access to `ConwayGovState` by making its lens part of `ConwayEraGov`. + * Export `gasExpiresAfterL` for use in tests * Add `ExpirationEpochTooSmall` data constructor to `ConwayGovPredFailure` * Add `ConflictingCommitteeUpdate` data constructor to `ConwayGovPredFailure` * Rename `NewCommitte` to `UpdateCommittee` diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index d45d367eb46..caac2ccee07 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -81,6 +81,7 @@ module Cardano.Ledger.Conway.Governance ( prevCommitteeStateL, gasCommitteeVotesL, gasDRepVotesL, + gasExpiresAfterL, gasStakePoolVotesL, ) where @@ -133,6 +134,7 @@ import Cardano.Ledger.Conway.Governance.Procedures ( VotingProcedures (..), gasCommitteeVotesL, gasDRepVotesL, + gasExpiresAfterL, gasStakePoolVotesL, govActionIdToText, indexedGovProps, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs index acd0c94db06..e7057c4e6a7 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs @@ -41,6 +41,7 @@ module Cardano.Ledger.Conway.Governance.Procedures ( gasDRepVotesL, gasStakePoolVotesL, gasCommitteeVotesL, + gasExpiresAfterL, ) where import Cardano.Crypto.Hash (hashToTextAsHex) @@ -193,6 +194,9 @@ gasDRepVotesL = lens gasDRepVotes (\x y -> x {gasDRepVotes = y}) gasStakePoolVotesL :: Lens' (GovActionState era) (Map (KeyHash 'StakePool (EraCrypto era)) Vote) gasStakePoolVotesL = lens gasStakePoolVotes (\x y -> x {gasStakePoolVotes = y}) +gasExpiresAfterL :: Lens' (GovActionState era) EpochNo +gasExpiresAfterL = lens gasExpiresAfter $ \x y -> x {gasExpiresAfter = y} + instance EraPParams era => ToExpr (GovActionState era) instance EraPParams era => ToJSON (GovActionState era) where diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs index 82768226e06..f98e574edb2 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs @@ -28,15 +28,18 @@ import Cardano.Ledger.BaseTypes ( textToUrl, ) import Cardano.Ledger.Block (txid) +import Cardano.Ledger.CertState import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) import Cardano.Ledger.Conway.Core ( dvtUpdateToConstitutionL, ) import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.PParams +import Cardano.Ledger.Conway.TxBody import Cardano.Ledger.Conway.TxCert import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) import Cardano.Ledger.Crypto -import Cardano.Ledger.DRepDistr (DRepDistr (..)) +import Cardano.Ledger.DRepDistr (DRepDistr (..), drepExpiryL) import Cardano.Ledger.Keys ( KeyHash, KeyRole (..), @@ -54,14 +57,18 @@ import Cardano.Ledger.Shelley.API ( import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.TxIn (TxIn (..)) import Cardano.Ledger.Val (Val (..), inject) +import Control.Exception (evaluate) import Control.State.Transition.Extended hiding (Assertion) import Data.Default.Class (Default (..)) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Ratio ((%)) +import qualified Data.Sequence as Seq +import qualified Data.Sequence.Strict as SSeq import GHC.Stack import Lens.Micro +import Test.Cardano.Ledger.Binary.TreeDiff (assertExprEqualWithMessage) import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..)) import Test.Cardano.Ledger.Examples.BabbageFeatures ( InitOutputs (..), @@ -80,6 +87,7 @@ import Test.Cardano.Ledger.Generic.Fields ( TxBodyField (..), TxOutField (..), ) +import Test.Cardano.Ledger.Generic.PrettyCore () import Test.Cardano.Ledger.Generic.Proof import Test.Cardano.Ledger.Generic.Scriptic (Scriptic (..)) import Test.Cardano.Ledger.Generic.Updaters @@ -94,14 +102,6 @@ import Test.Cardano.Protocol.Crypto.VRF (VRFKeyPair (..)) import Test.Tasty import Test.Tasty.HUnit -import Cardano.Ledger.Conway.PParams (ConwayEraPParams, ppDRepActivityL, ppDRepVotingThresholdsL, ppGovActionDepositL, ppGovActionExpirationL) -import Cardano.Ledger.Conway.TxBody (ConwayEraTxBody) -import Control.Exception (evaluate) -import qualified Data.Sequence as Seq -import qualified Data.Sequence.Strict as SSeq -import Test.Cardano.Ledger.Binary.TreeDiff (assertExprEqualWithMessage) -import Test.Cardano.Ledger.Generic.PrettyCore () - stakeKeyHash :: forall era. Era era => Proof era -> KeyHash 'Staking (EraCrypto era) stakeKeyHash _pf = hashKey . snd $ mkKeyPair (RawSeed 0 0 0 0 2) @@ -191,6 +191,13 @@ govActionState gaid ProposalProcedure {..} = (EpochNo 0) (EpochNo 30) +expiringGovActionState :: + EpochNo -> + GovActionId (EraCrypto era) -> + ProposalProcedure era -> + GovActionState era +expiringGovActionState expiry govActionId pposal = govActionState govActionId pposal & gasExpiresAfterL .~ expiry + govActionStateWithYesVotes :: Scriptic era => GovActionId (EraCrypto era) -> Proof era -> ProposalProcedure era -> GovActionState era govActionStateWithYesVotes gaid pf ProposalProcedure {..} = GovActionState @@ -321,6 +328,129 @@ vote pf govActionId = , otherWitsFields = [] } +preventDRepExpiry :: + forall era. + ( State (EraRule "LEDGER" era) ~ LedgerState era + , State (EraRule "EPOCH" era) ~ EpochState era + , Show (PredicateFailure (EraRule "LEDGER" era)) + , Show (PredicateFailure (EraRule "EPOCH" era)) + , Scriptic era + , GoodCrypto (EraCrypto era) + , EraTx era + , ConwayEraTxBody era + , GovState era ~ ConwayGovState era + , ConwayEraPParams era + , ConwayEraGov era + ) => + Proof era -> + Assertion +preventDRepExpiry pf = do + let + (utxo0, _) = utxoFromTestCaseData pf (proposal pf) + pp' = pp & ppGovActionExpirationL .~ 3 + proposalTx = txFromTestCaseData pf (proposal pf) + govActionId = GovActionId (txid (proposalTx ^. bodyTxL)) (GovActionIx 0) + initialGov = + def + & cgEnactStateL . ensCurPParamsL .~ pp' + & cgGovSnapshotsL . curGovSnapshotsL + .~ fromGovActionStateSeq (SSeq.singleton $ expiringGovActionState (EpochNo 2) govActionId $ newConstitutionProposal pf) + initialLedgerState = LedgerState (smartUTxOState pp' utxo0 (Coin 10) (Coin 0) initialGov zero) def + drepDistr = DRComplete $ Map.fromList [(DRepCredential (drepCredential pf), CompactCoin 1000)] + dreps = Map.singleton (drepCredential pf) (DRepState (EpochNo 2) SNothing (Coin 0)) + epochState0 = + def + & curPParamsEpochStateL .~ pp' + & esLStateL .~ (initialLedgerState & lsCertStateL . certVStateL . vsDRepsL .~ dreps) + & epochStateDRepDistrL .~ drepDistr + poolDistr = + PoolDistr + ( Map.fromList + [ + ( stakePoolKeyHash pf + , IndividualPoolStake + spoThreshold + (vrfKeyHash @(EraCrypto era)) + ) + ] + ) + assertDReps epochNo epochState = + assertExprEqualWithMessage + (unwords ["Epoch", show @Int epochNo, "- DReps"]) + (epochState ^. esLStateL . lsCertStateL . certVStateL . vsDRepsL) + assertCurGovSnaps epochNo epochState = + assertExprEqualWithMessage + (unwords ["Epoch", show @Int epochNo, "- CurGovSnapshot"]) + (SSeq.null . snapshotIds $ epochState ^. esLStateL . lsUTxOStateL . utxosGovStateL . snapshotsGovStateL . curGovSnapshotsL) + assertPrevGovSnaps epochNo epochState = + assertExprEqualWithMessage + (unwords ["Epoch", show @Int epochNo, "- PrevGovSnapshot"]) + (SSeq.null . snapshotIds $ epochState ^. esLStateL . lsUTxOStateL . utxosGovStateL . snapshotsGovStateL . prevGovSnapshotsL) + assertNumDormantEpochs epochNo prevEpochState currEpochState doesAdvance = + assertExprEqualWithMessage + (unwords ["Epoch", show @Int epochNo, "- NumDormantEpochs"]) + (prevEpochState ^. esLStateL . lsCertStateL . certVStateL . vsNumDormantEpochsL + (if doesAdvance then 1 else 0)) + (currEpochState ^. esLStateL . lsCertStateL . certVStateL . vsNumDormantEpochsL) + + assertDReps 0 epochState0 dreps + assertCurGovSnaps 0 epochState0 False + assertPrevGovSnaps 0 epochState0 True + + epochState1 <- expectRight "Error running runEPOCH: " $ runEPOCH (EPOCH pf) epochState0 (EpochNo 1) poolDistr + + assertNumDormantEpochs 1 epochState0 epochState1 True + assertDReps 1 epochState1 dreps + assertCurGovSnaps 1 epochState1 False + assertPrevGovSnaps 1 epochState1 False + + epochState2 <- expectRight "Error running runEPOCH: " $ runEPOCH (EPOCH pf) epochState1 (EpochNo 2) poolDistr + + assertNumDormantEpochs 2 epochState1 epochState2 False + assertDReps 2 epochState2 dreps + assertCurGovSnaps 2 epochState2 False + assertPrevGovSnaps 2 epochState2 False + + epochState3 <- expectRight "Error running runEPOCH: " $ runEPOCH (EPOCH pf) epochState2 (EpochNo 3) poolDistr + + assertNumDormantEpochs 3 epochState2 epochState3 False + assertDReps 3 epochState3 dreps + assertCurGovSnaps 3 epochState3 False + assertPrevGovSnaps 3 epochState3 False + + epochState4 <- expectRight "Error running runEPOCH: " $ runEPOCH (EPOCH pf) epochState3 (EpochNo 4) poolDistr + + assertNumDormantEpochs 4 epochState3 epochState4 False + assertDReps 4 epochState4 dreps + assertCurGovSnaps 4 epochState4 True + assertPrevGovSnaps 4 epochState4 True + + epochState5 <- expectRight "Error running runEPOCH: " $ runEPOCH (EPOCH pf) epochState4 (EpochNo 5) poolDistr + + assertNumDormantEpochs 5 epochState4 epochState5 True + assertDReps 5 epochState5 dreps + assertCurGovSnaps 5 epochState5 True + assertPrevGovSnaps 5 epochState5 True + + -- Propose something + ledgerState5 <- + expectRight "Error running LEDGER when proposing: " $ + runLEDGER (LEDGER pf) (epochState5 ^. esLStateL) pp' (trustMeP pf True proposalTx) + let epochState5' = epochState5 & esLStateL .~ ledgerState5 + -- Check that the vsNumDormantEpochsL has been reset to 0 + assertExprEqualWithMessage + "Epoch 5 - NumDormantEpochs after proposal" + (ledgerState5 ^. lsCertStateL . certVStateL . vsNumDormantEpochsL) + 0 + -- Check that the vsDRepsL <&> drepExpiryL has been bumped by the number vsNumDormantEpochsL + assertDReps 5 epochState5' (dreps <&> drepExpiryL %~ (+ 2)) + + epochState6 <- expectRight "Error running runEPOCH: " $ runEPOCH (EPOCH pf) epochState5' (EpochNo 6) poolDistr + + assertNumDormantEpochs 6 epochState5' epochState6 True + assertDReps 6 epochState6 (dreps <&> drepExpiryL %~ (+ 2)) + assertCurGovSnaps 6 epochState6 False + assertPrevGovSnaps 6 epochState6 False + testGov :: forall era. ( State (EraRule "LEDGER" era) ~ LedgerState era @@ -475,4 +605,5 @@ conwayFeatures = testGroup "Gov examples" [ testCase "gov" $ testGov (Conway Mock) + , testCase "Prevent DRep expiry when there are no proposals to vote on" $ preventDRepExpiry (Conway Mock) ]