diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index d47e75f47b5..044b7825241 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.17.0.0 +* Added `reDelegatees` and `rePoolParams` to `RatifyEnv` for updated SPO vote calculation #4645 +* Added `dpPoolParams` to `DRepPulser` to track the parameters of each stake pool * Add `HardForkEvent` constructor to `ConwayEpochEvent` * Add `HardFork` module, `ConwayHARDFORK` and `ConwayHardForkEvent` * Add predicate failures to guard against invalid reward accounts (return addresses) in proposals and treasury withdrawals. #4639 diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index c4a576fe4a0..fdac1dca97d 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -211,6 +211,7 @@ import Cardano.Ledger.Shelley.LedgerState ( credMap, dsUnified, epochStateGovStateL, + epochStatePoolParamsL, epochStateTreasuryL, esLStateL, lsCertState, @@ -492,6 +493,7 @@ setFreshDRepPulsingState epochNo stakePoolDistr epochState = do , dpProposals = proposalsActions props , dpProposalDeposits = proposalsDeposits props , dpGlobals = globals + , dpPoolParams = epochState ^. epochStatePoolParamsL } ) pure $ epochState & epochStateGovStateL .~ govState' diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs index 737ce681f31..099961eeff3 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs @@ -63,6 +63,7 @@ import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.DRep (DRep (..), DRepState (..)) import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) import Cardano.Ledger.PoolDistr +import Cardano.Ledger.PoolParams (PoolParams) import Cardano.Ledger.UMap import qualified Cardano.Ledger.UMap as UMap import Control.DeepSeq (NFData (..), deepseq) @@ -278,6 +279,9 @@ data DRepPulser era (m :: Type -> Type) ans where , dpProposalDeposits :: !(Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)) -- ^ Snapshot of the proposal-deposits per reward-account-staking-credential , dpGlobals :: !Globals + , dpPoolParams :: !(Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))) + -- ^ Snapshot of the parameters of stake pools - + -- this is needed to get the reward account for SPO vote calculation } -> DRepPulser era m ans @@ -308,7 +312,7 @@ deriving instance (EraPParams era, Show ans) => Show (DRepPulser era m ans) instance EraPParams era => NoThunks (DRepPulser era Identity (RatifyState era)) where showTypeOf _ = "DRepPulser" - wNoThunks ctxt drp@(DRepPulser _ _ _ _ _ _ _ _ _ _ _ _ _) = + wNoThunks ctxt drp@(DRepPulser _ _ _ _ _ _ _ _ _ _ _ _ _ _) = allNoThunks [ noThunks ctxt (dpPulseSize drp) , noThunks ctxt (dpUMap drp) @@ -323,10 +327,11 @@ instance EraPParams era => NoThunks (DRepPulser era Identity (RatifyState era)) , noThunks ctxt (dpProposals drp) , noThunks ctxt (dpProposalDeposits drp) , noThunks ctxt (dpGlobals drp) + , noThunks ctxt (dpPoolParams drp) ] instance EraPParams era => NFData (DRepPulser era Identity (RatifyState era)) where - rnf (DRepPulser n um bal stake pool drep dstate ep cs es as pds gs) = + rnf (DRepPulser n um bal stake pool drep dstate ep cs es as pds gs poolps) = n `deepseq` um `deepseq` bal `deepseq` @@ -339,7 +344,8 @@ instance EraPParams era => NFData (DRepPulser era Identity (RatifyState era)) wh es `deepseq` as `deepseq` pds `deepseq` - rnf gs + gs `deepseq` + rnf poolps class ( STS (ConwayRATIFY era) @@ -386,6 +392,8 @@ finishDRepPulser (DRPulsing (DRepPulser {..})) = , reDRepState = dpDRepState , reCurrentEpoch = dpCurrentEpoch , reCommitteeState = dpCommitteeState + , reDelegatees = dRepMap dpUMap + , rePoolParams = dpPoolParams } !ratifySig = RatifySignal dpProposals !ratifyState = diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Internal.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Internal.hs index a9bb951b93a..dde7cb43967 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Internal.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Internal.hs @@ -115,8 +115,9 @@ import Cardano.Ledger.Core ( ) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.DRep (DRep (..), DRepState (..)) -import Cardano.Ledger.Keys (KeyRole (..)) +import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) import Cardano.Ledger.PoolDistr (PoolDistr (..)) +import Cardano.Ledger.PoolParams (PoolParams) import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase) import Cardano.Ledger.Shelley.LedgerState ( epochStateIncrStakeDistrL, @@ -558,6 +559,8 @@ data RatifyEnv era = RatifyEnv , reDRepState :: !(Map (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))) , reCurrentEpoch :: !EpochNo , reCommitteeState :: !(CommitteeState era) + , reDelegatees :: !(Map (Credential 'Staking (EraCrypto era)) (DRep (EraCrypto era))) + , rePoolParams :: !(Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))) } deriving (Generic) @@ -585,11 +588,20 @@ deriving instance Show (RatifyEnv era) deriving instance Eq (RatifyEnv era) instance Default (RatifyEnv era) where - def = RatifyEnv Map.empty (PoolDistr Map.empty mempty) Map.empty Map.empty (EpochNo 0) def + def = + RatifyEnv + Map.empty + (PoolDistr Map.empty mempty) + Map.empty + Map.empty + (EpochNo 0) + def + Map.empty + Map.empty instance Typeable era => NoThunks (RatifyEnv era) where showTypeOf _ = "RatifyEnv" - wNoThunks ctxt (RatifyEnv stake pool drep dstate ep cs) = + wNoThunks ctxt (RatifyEnv stake pool drep dstate ep cs delegatees poolps) = allNoThunks [ noThunks ctxt stake , noThunks ctxt pool @@ -597,19 +609,23 @@ instance Typeable era => NoThunks (RatifyEnv era) where , noThunks ctxt dstate , noThunks ctxt ep , noThunks ctxt cs + , noThunks ctxt delegatees + , noThunks ctxt poolps ] instance Era era => NFData (RatifyEnv era) where - rnf (RatifyEnv stake pool drep dstate ep cs) = + rnf (RatifyEnv stake pool drep dstate ep cs delegatees poolps) = stake `deepseq` pool `deepseq` drep `deepseq` dstate `deepseq` ep `deepseq` - rnf cs + cs `deepseq` + delegatees `deepseq` + rnf poolps instance Era era => EncCBOR (RatifyEnv era) where - encCBOR env@(RatifyEnv _ _ _ _ _ _) = + encCBOR env@(RatifyEnv _ _ _ _ _ _ _ _) = let RatifyEnv {..} = env in encode $ Rec (RatifyEnv @era) @@ -619,6 +635,8 @@ instance Era era => EncCBOR (RatifyEnv era) where !> To reDRepState !> To reCurrentEpoch !> To reCommitteeState + !> To reDelegatees + !> To rePoolParams instance Era era => DecCBOR (RatifyEnv era) where decCBOR = @@ -630,6 +648,8 @@ instance Era era => DecCBOR (RatifyEnv era) where EncCBOR (RatifyState era) where encCBOR (RatifyState es enacted expired delayed) = diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs index d51ec147c8d..eb964d4ba0f 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs @@ -27,8 +27,10 @@ module Cardano.Ledger.Conway.Rules.Ratify ( withdrawalCanWithdraw, ) where +import Cardano.Ledger.Address (RewardAccount (..)) import Cardano.Ledger.BaseTypes ( BoundedRational (..), + ProtVer, ShelleyBase, StrictMaybe (..), addEpochInterval, @@ -53,6 +55,7 @@ import Cardano.Ledger.Conway.Governance ( RatifyState (..), Vote (..), ensCommitteeL, + ensProtVerL, ensTreasuryL, gasAction, rsDelayedL, @@ -73,6 +76,8 @@ import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.DRep (DRep (..), DRepState (..)) import Cardano.Ledger.Keys (KeyRole (..)) import Cardano.Ledger.PoolDistr (PoolDistr (..), individualTotalPoolStake) +import Cardano.Ledger.PoolParams (PoolParams (..)) +import Cardano.Ledger.Shelley.HardForks (bootstrapPhase) import Cardano.Ledger.Slot (EpochNo (..)) import Cardano.Ledger.Val (Val (..), (<+>)) import Control.State.Transition.Extended ( @@ -173,10 +178,12 @@ spoAccepted :: spoAccepted re rs gas = case votingStakePoolThreshold rs (gasAction gas) of -- Short circuit on zero threshold in order to avoid redundant computation. - SJust r -> r == minBound || spoAcceptedRatio re gas >= unboundRational r + SJust r -> + r == minBound || spoAcceptedRatio re gas (rs ^. rsEnactStateL . ensProtVerL) >= unboundRational r SNothing -> False --- | Final ratio for `totalAcceptedStakePoolsRatio` we want is: t = y \/ (s - a) +-- | Final ratio for `totalAcceptedStakePoolsRatio` we want during the bootstrap period is: +-- t = y \/ (s - a) -- Where: -- * `y` - total delegated stake that voted Yes -- * `a` - total delegated stake that voted Abstain @@ -187,13 +194,23 @@ spoAccepted re rs gas = -- vote are considered as `Abstain` votes. -- -- `No` votes are not counted. -spoAcceptedRatio :: forall era. RatifyEnv era -> GovActionState era -> Rational +-- After the bootstrap period if an SPO didn't vote, it will be considered as a `No` vote by default. +-- The only exceptions are when a pool delegated to an `AlwaysNoConfidence` or an `AlwaysAbstain` DRep. +-- In those cases, behaviour is as expected: vote `Yes` on `NoConfidence` proposals in case of the former and +-- and vote `Abstain` by default in case of the latter. For `HardForkInitiation`, behaviour is the same as +-- during the bootstrap period: if an SPO didn't vote, their vote will always count as `No`. +spoAcceptedRatio :: forall era. RatifyEnv era -> GovActionState era -> ProtVer -> Rational spoAcceptedRatio - RatifyEnv {reStakePoolDistr = PoolDistr individualPoolStake (CompactCoin totalActiveStake)} + RatifyEnv + { reStakePoolDistr = PoolDistr individualPoolStake (CompactCoin totalActiveStake) + , reDelegatees + , rePoolParams + } GovActionState { gasStakePoolVotes , gasProposalProcedure = ProposalProcedure {pProcGovAction} } + pv | totalActiveStake == 0 = 0 -- guard against the degenerate case when active stake is zero. | totalActiveStake == abstainStake = 0 -- guard against the degenerate case when all abstain. | otherwise = toInteger yesStake % toInteger (totalActiveStake - abstainStake) @@ -201,10 +218,18 @@ spoAcceptedRatio accumStake (!yes, !abstain) poolId distr = let CompactCoin stake = individualTotalPoolStake distr vote = Map.lookup poolId gasStakePoolVotes + drep = + Map.lookup poolId rePoolParams >>= \d -> + Map.lookup (raCredential $ ppRewardAccount d) reDelegatees in case vote of Nothing | HardForkInitiation {} <- pProcGovAction -> (yes, abstain) - | otherwise -> (yes, abstain + stake) + | bootstrapPhase pv -> (yes, abstain + stake) + | otherwise -> case drep of + Just DRepAlwaysNoConfidence + | NoConfidence {} <- pProcGovAction -> (yes + stake, abstain) + Just DRepAlwaysAbstain -> (yes, abstain + stake) + _ -> (yes, abstain) Just Abstain -> (yes, abstain + stake) Just VoteNo -> (yes, abstain) Just VoteYes -> (yes + stake, abstain) diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs index 9f4df929243..fa99cfda142 100644 --- a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs @@ -330,3 +330,5 @@ emptyRatifyEnv = Map.empty (EpochNo 0) (CommitteeState Map.empty) + Map.empty + Map.empty diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index 09b25e07c29..0367b8c43b5 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -198,6 +198,8 @@ instance <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary + <*> arbitrary shrink = genericShrink diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs index 4a1583dd8dc..e8c4044f107 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs @@ -337,10 +337,11 @@ paramChangeAffectsProposalsSpec = enactThreshold largerThreshold drepC hotCommitteeC isDRepAccepted gaiChild `shouldReturn` False it "Decreasing the threshold ratifies a hitherto-unratifiable proposal" $ do + -- This sets up a stake pool with 1_000_000 Coin (drepC, hotCommitteeC, _) <- electBasicCommittee setThreshold largerThreshold (drep, _, _) <- setupSingleDRep 1_000_000 - (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000 + (spoC, _, _) <- setupPoolWithStake $ Coin 3_000_000 (gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild [(spoC, VoteYes)] [(drep, VoteYes)] isDRepAccepted gaiChild `shouldReturn` False @@ -348,6 +349,8 @@ paramChangeAffectsProposalsSpec = isDRepAccepted gaiChild `shouldReturn` True -- Not vote on the parent too to make sure both get enacted submitYesVote_ (DRepVoter drep) gaiParent + -- bootstrap: 3 % 4 stake yes; 1 % 4 stake abstain; yes / stake - abstain > 1 % 2 + -- post-bootstrap: 3 % 4 stake yes; 1 % 4 stake no submitYesVote_ (StakePoolVoter spoC) gaiParent passNEpochs 2 getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiParent) @@ -372,11 +375,14 @@ paramChangeAffectsProposalsSpec = submitYesVote_ (CommitteeVoter hotCommitteeC) pcGai passNEpochs 2 it "Increasing the threshold prevents a hitherto-ratifiable proposal from being ratified" $ do + -- This sets up a stake pool with 1_000_000 Coin (drepC, hotCommitteeC, _) <- electBasicCommittee setThreshold smallerThreshold - (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 1_000_000 + (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 2_000_000 (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000 passEpoch -- Make the new pool distribution count + -- bootstrap: 1 % 2 stake yes (2_000_000); 1 % 2 stake abstain; yes / stake - abstain == 1 % 2 + -- post-bootstrap: 1 % 2 stake yes (2_000_000); 1 % 4 stake didn't vote; 1 % 4 stake no (_gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild [(poolKH1, VoteYes), (poolKH2, VoteNo)] @@ -385,10 +391,13 @@ paramChangeAffectsProposalsSpec = enactThreshold largerThreshold drepC hotCommitteeC isSpoAccepted gaiChild `shouldReturn` False it "Decreasing the threshold ratifies a hitherto-unratifiable proposal" $ do + -- This sets up a stake pool with 1_000_000 Coin (drepC, hotCommitteeC, _) <- electBasicCommittee setThreshold largerThreshold - (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 1_000_000 + (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 2_000_000 (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000 + -- bootstrap: 1 % 2 stake yes (2_000_000); 1 % 2 stake abstain; yes / stake - abstain == 1 % 2 + -- post-bootstrap: 1 % 2 stake yes (2_000_000); 1 % 4 stake didn't vote; 1 % 4 stake no (gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild [(poolKH1, VoteYes), (poolKH2, VoteNo)] @@ -521,10 +530,14 @@ spoVotesCommitteeUpdates = modifyPParams $ ppPoolVotingThresholdsL . pvtMotionNoConfidenceL .~ 1 %! 2 whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL .~ def) gai <- submitGovAction $ NoConfidence SNothing - -- 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2 + -- bootstrap: 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2 + -- post-bootstrap: 1 % 4 stake yes; 3 % 4 stake no; yes stake < 1 % 2 submitYesVote_ (StakePoolVoter spoK1) gai passNEpochs 2 - getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai) + pv <- getProtVer + if bootstrapPhase pv + then getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai) + else getLastEnactedCommittee `shouldReturn` SNothing it "CommitteeUpdate" $ do (spoK1, _, _) <- setupPoolWithStake $ Coin 100_000_000 _ <- setupPoolWithStake $ Coin 100_000_000 @@ -534,11 +547,14 @@ spoVotesCommitteeUpdates = whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL .~ def) cc <- KeyHashObj <$> freshKeyHash gai <- submitUpdateCommittee Nothing mempty [(cc, EpochInterval 5)] (1 %! 2) - -- 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2 + -- bootstrap: 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2 + -- post-bootstrap: 1 % 4 stake yes; 3 % 4 stake no; yes stake < 1 % 2 submitYesVote_ (StakePoolVoter spoK1) gai passNEpochs 2 - getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai) - + pv <- getProtVer + if bootstrapPhase pv + then getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai) + else getLastEnactedCommittee `shouldReturn` SNothing spoVotesForHardForkInitiation :: forall era. ConwayEraImp era => diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs index 5c1930f325d..80c747f8ecf 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -178,6 +178,7 @@ import Cardano.Ledger.Shelley.LedgerState ( certVStateL, curPParamsEpochStateL, epochStateGovStateL, + epochStatePoolParamsL, esAccountStateL, esLStateL, lsCertStateL, @@ -187,12 +188,14 @@ import Cardano.Ledger.Shelley.LedgerState ( nesEsL, nesPdL, newEpochStateGovStateL, + unifiedL, utxosGovStateL, utxosStakeDistrL, vsCommitteeStateL, vsDRepsL, ) import Cardano.Ledger.TxIn (TxId (..)) +import Cardano.Ledger.UMap (dRepMap) import Cardano.Ledger.Val ((<->)) import Control.Monad (forM) import Control.Monad.Trans.Fail.String (errorFail) @@ -1004,6 +1007,8 @@ getRatifyEnv = do drepDistr <- getsNES $ nesEsL . epochStateDRepPulsingStateL . psDRepDistrG drepState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL committeeState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsCommitteeStateL + umap <- getsNES $ unifiedL + poolPs <- getsNES $ nesEsL . epochStatePoolParamsL pure RatifyEnv { reStakePoolDistr = poolDistr @@ -1012,6 +1017,8 @@ getRatifyEnv = do , reDRepDistr = drepDistr , reCurrentEpoch = eNo - 1 , reCommitteeState = committeeState + , reDelegatees = dRepMap umap + , rePoolParams = poolPs } ccShouldNotBeExpired :: @@ -1106,7 +1113,8 @@ calculatePoolAcceptedRatio :: calculatePoolAcceptedRatio gaId = do ratEnv <- getRatifyEnv gas <- getGovActionState gaId - pure $ spoAcceptedRatio ratEnv gas + pv <- getProtVer + pure $ spoAcceptedRatio ratEnv gas pv -- | Logs the ratios of accepted votes per category logAcceptedRatio :: @@ -1179,6 +1187,7 @@ logRatificationChecks gaId = do let ratSt = RatifyState ens mempty mempty False curTreasury <- getsNES $ nesEsL . esAccountStateL . asTreasuryL currentEpoch <- getsNES nesELL + pv <- getProtVer let members = foldMap' committeeMembers committee committeeState = reCommitteeState ratEnv @@ -1208,7 +1217,7 @@ logRatificationChecks gaId = do [ viaShow $ spoAccepted ratEnv ratSt gas , "[" , "To Pass:" - , viaShow $ spoAcceptedRatio ratEnv gas + , viaShow $ spoAcceptedRatio ratEnv gas pv , ">=" , viaShow $ votingStakePoolThreshold ratSt (gasAction gas) , "]" diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs index 3c076efa791..8dc1f620ceb 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs @@ -126,8 +126,18 @@ instance (a, b) = finishDRepPulser x instance ToExpr (RatifyEnv era) where - toExpr (RatifyEnv stake pool drep dstate ep cs) = - App "RatifyEnv" [toExpr stake, toExpr pool, toExpr drep, toExpr dstate, toExpr ep, toExpr cs] + toExpr (RatifyEnv stake pool drep dstate ep cs delegatees poolps) = + App + "RatifyEnv" + [ toExpr stake + , toExpr pool + , toExpr drep + , toExpr dstate + , toExpr ep + , toExpr cs + , toExpr delegatees + , toExpr poolps + ] -- Rules/Gov instance (EraPParams era, ToExpr (PParamsHKD StrictMaybe era)) => ToExpr (ConwayGovPredFailure era) diff --git a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway/Base.hs b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway/Base.hs index 1e69944a0bc..7297abf7bcd 100644 --- a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway/Base.hs +++ b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Conway/Base.hs @@ -56,8 +56,11 @@ import Cardano.Ledger.Conway.Governance ( RatifyEnv (..), RatifySignal (..), RatifyState (..), + Vote (Abstain), VotingProcedures, + ensProtVerL, gasAction, + rsEnactStateL, showGovActionType, ) import Cardano.Ledger.Conway.Rules ( @@ -85,7 +88,7 @@ import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set import qualified Data.Text as T import GHC.Generics (Generic) -import Lens.Micro (Lens', lens, (&), (.~)) +import Lens.Micro (Lens', lens, (&), (.~), (^.)) import qualified Lib as Agda import qualified Prettyprinter as PP import Test.Cardano.Ledger.Binary.TreeDiff (tableDoc) @@ -315,7 +318,7 @@ ratifyEnvSpec :: ConwayRatifyExecContext Conway -> Specification fn (RatifyEnv Conway) ratifyEnvSpec ConwayRatifyExecContext {crecGovActionMap} = - constrained' $ \_ poolDistr drepDistr drepState _ committeeState -> + constrained' $ \_ poolDistr drepDistr drepState _ committeeState _ _ -> [ -- Bias the generator towards generating DReps that have stake and are registered exists ( \eval -> @@ -376,7 +379,9 @@ ratifyEnvSpec ConwayRatifyExecContext {crecGovActionMap} = spoVotes = foldr' ( \GovActionState {gasStakePoolVotes} s -> - Map.keysSet gasStakePoolVotes <> s + -- TODO: Remove the filter when + -- /~https://github.com/IntersectMBO/formal-ledger-specifications/issues/578 is resolved + Map.keysSet (Map.filter (== Abstain) gasStakePoolVotes) <> s ) mempty crecGovActionMap @@ -485,6 +490,7 @@ instance IsConwayUniv fn => ExecSpecRule fn "RATIFY" Conway where <*> toSpecRep st <*> toSpecRep sig ] + pv = st ^. rsEnactStateL . ensProtVerL actionAcceptedRatio gas@GovActionState {..} = tableDoc (Just "GovActionState") @@ -495,7 +501,7 @@ instance IsConwayUniv fn => ExecSpecRule fn "RATIFY" Conway where , ( "SPO:" , showAccepted (spoAccepted env st gas) - PP.<+> showRatio (spoAcceptedRatio env gas) + PP.<+> showRatio (spoAcceptedRatio env gas pv) ) , ( "DRep:" @@ -524,6 +530,7 @@ instance IsConwayUniv fn => ExecSpecRule fn "RATIFY" Conway where | otherwise = error "ratio is not in the unit interval" committee = ensCommittee rsEnactState members = foldMap' (committeeMembers @Conway) committee + pv = st ^. rsEnactStateL . ensProtVerL ccBucket a = "CC yes votes ratio \t" <> bucket @@ -540,7 +547,7 @@ instance IsConwayUniv fn => ExecSpecRule fn "RATIFY" Conway where spoBucket a = "SPO yes votes ratio \t" <> bucket - (spoAcceptedRatio env a) + (spoAcceptedRatio env a pv) acceptedActions = fmap gasAction . filter (acceptedByEveryone env st) $ toList actions acceptedActionTypes = Set.fromList $ showGovActionType <$> acceptedActions labelRatios diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs index ec882d51a3b..02d17328318 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs @@ -1317,6 +1317,7 @@ type DRepPulserTypes = , EnactState Conway , StrictSeq (GovActionState Conway) , Map (Credential 'Staking StandardCrypto) (CompactForm Coin) + , Map (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto) ] instance HasSimpleRep @@ -1339,11 +1340,12 @@ instance dpEnactState dpProposals dpProposalDeposits + dpPoolParams fromSimpleRep rep = algebra @'["DRepPulser" ::: DRepPulserTypes] rep - $ \ps um b sd spd dd ds ce cs es p pds -> - DRepPulser ps um b sd spd dd ds ce cs es p pds testGlobals + $ \ps um b sd spd dd ds ce cs es p pds poolps -> + DRepPulser ps um b sd spd dd ds ce cs es p pds testGlobals poolps instance (EraPP Conway, IsConwayUniv fn) => HasSpec fn (DRepPulser Conway Identity (RatifyState Conway)) 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 b1883ea3b71..5c99c30c749 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 @@ -967,6 +967,7 @@ genSizedRep _ DRepPulserR = do <*> pure props <*> pure (proposalsDeposits $ def & pPropsL .~ OMap.fromFoldable props) <*> pure testGlobals + <*> arbitrary -- poolparams genSizedRep n DelegateeR = oneof [ DelegStake <$> genSizedRep n (PoolHashR @era) 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 9c13de475d3..ac8ffbdf3e0 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 @@ -1739,7 +1739,7 @@ pulsingPairT proof = Invert "DRepPulser" (typeRep @(UtxoPulse era)) - (\utx a b c d e f g -> (utx, initPulser proof utx a b c d e f g)) + (\utx a b c d e f g h -> (utx, initPulser proof utx a b c d e f g h)) :$ Lensed (utxo proof) _1 :$ Virtual drepDelegation (ppString "prevDRepDelegations") (_2 . prevDRepDelegationsL) :$ Virtual poolDistr (ppString "prevPoolDistr") (_2 . prevPoolDistrL) @@ -1748,6 +1748,7 @@ pulsingPairT proof = :$ Virtual committeeState (ppString "prevCommitteeState") (_2 . prevCommitteeStateL) :$ Shift enactStateT (_2 . prevEnactStateL) :$ Virtual currGovStates (ppString "prevProposals") (_2 . ratifyGovActionStatesL) + :$ Virtual regPools (ppString "prevPoolParams") (_2 . prevRegPoolsL) -- TODO access prevTreasury from the EnactState -- :$ Virtual treasury (ppString "prevTreasury") (_2 . prevTreasuryL) @@ -1769,6 +1770,7 @@ justPulser p = :$ Virtual committeeState (ppString "prevCommitteeState") prevCommitteeStateL :$ Shift enactStateT prevEnactStateL :$ Virtual currGovStates (ppString "prevProposals") ratifyGovActionStatesL + :$ Virtual regPools (ppString "prevPoolParams") prevRegPoolsL -- TODO access prevTreasury from the EnactState -- :$ Virtual treasury (ppString "prevTreasury") (prevTreasuryL) @@ -1843,8 +1845,9 @@ initPulser :: EnactState era -> [GovActionState era] -> -- Coin -> + Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)) -> DRepPulser era Identity (RatifyState era) -initPulser proof utx credDRepMap poold credDRepStateMap epoch commstate enactstate govstates {- treas -} = +initPulser proof utx credDRepMap poold credDRepStateMap epoch commstate enactstate govstates {- treas -} poolParams = let umap = unify Map.empty Map.empty Map.empty credDRepMap umapSize = Map.size credDRepMap k = securityParameter testGlobals @@ -1866,6 +1869,7 @@ initPulser proof utx credDRepMap poold credDRepStateMap epoch commstate enactsta (proposalsDeposits $ def & pPropsL .~ OMap.fromFoldable govstates) -- treas testGlobals + poolParams proposalsT :: forall era. Era era => Proof era -> RootTarget era (Proposals era) (Proposals era) proposalsT proof = @@ -2037,6 +2041,19 @@ prevTreasuryL = lens dpTreasury (\x y -> x {dpTreasury = y}) partialIndividualPoolStake :: Era era => Term era (Map (KeyHash 'StakePool (EraCrypto era)) Coin) partialIndividualPoolStake = Var $ V "partialIndividualPoolStake" (MapR PoolHashR CoinR) No +prevRegPools :: + Era era => Term era (Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))) +prevRegPools = Var $ V "prevRegPools" (MapR PoolHashR PoolParamsR) No + +prevRegPoolsL :: + Lens' + (DRepPulser era Identity (RatifyState era)) + (Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))) +prevRegPoolsL = + lens + dpPoolParams + (\x y -> x {dpPoolParams = y}) + -- ====================================== -- ConwayGovState