From 565e8ef6402799a649a4bae2167e0dd8a10f604d Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 7 Sep 2023 17:28:16 +0400 Subject: [PATCH] Abstract threshold calculation: We need to have ability to answer if voting is allowed for a particilar entity by reusing the current threshold calculation logic, thus reducing duplication. This is needed for #3685 --- eras/conway/impl/CHANGELOG.md | 8 + .../src/Cardano/Ledger/Conway/Governance.hs | 185 +++++++++++++----- .../src/Cardano/Ledger/Conway/Rules/Ratify.hs | 8 +- .../Test/Cardano/Ledger/Conway/RatifySpec.hs | 4 +- 4 files changed, 152 insertions(+), 53 deletions(-) diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 8bbabf2f843..1e0b91eb19f 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,14 @@ ## 1.9.0.0 +* Rename: + * `thresholdSPO` -> `votingStakePoolThreshold` + * `thresholdDRep` -> `votingDRepThreshold` + * `thresholdCC` -> `votingCommitteeThreshold` +* Add: + * `isStakePoolVotingAllowed` + * `isDRepVotingAllowed` + * `isCommitteeVotingAllowed` * Fix `ConwayTxBodyRaw` decoder to disallow empty `Field`s #3712 * `certsTxBodyL` * `withdrawalsTxBodyL` diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index 678d8500ac4..492a8246550 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -42,9 +42,12 @@ module Cardano.Ledger.Conway.Governance ( indexedGovProps, Constitution (..), ConwayEraGov (..), - thresholdSPO, - thresholdDRep, - thresholdCC, + votingStakePoolThreshold, + votingDRepThreshold, + votingCommitteeThreshold, + isStakePoolVotingAllowed, + isDRepVotingAllowed, + isCommitteeVotingAllowed, ProposalsSnapshot, snapshotInsertGovAction, snapshotActions, @@ -85,6 +88,7 @@ import Cardano.Ledger.BaseTypes ( ProtVer (..), StrictMaybe (..), UnitInterval, + isSJust, ) import Cardano.Ledger.Binary ( DecCBOR (..), @@ -593,69 +597,156 @@ pparamsUpdateThreshold pp ppu = Set.map lookupGroupThreshold $ modifiedGroups @era ppu -thresholdSPO :: +data VotingThreshold + = -- | This is the actual threshold. It is lazy, because upon proposal we only care if + -- the voting is allowed or not, instead of getting the actual threshold value. + VotingThreshold UnitInterval -- <- lazy on purpose + | -- | Does not have a threshold, therefore an action can not be ratified + NoVotingThreshold + | -- | Some GovActions are not allowed to be voted by some entities + NoVotingAllowed + +toRatifyVotingThreshold :: VotingThreshold -> StrictMaybe UnitInterval +toRatifyVotingThreshold = \case + VotingThreshold t -> SJust t -- concrete threshold + NoVotingThreshold -> SNothing -- no voting threshold prevents ratification + NoVotingAllowed -> SJust minBound -- votes should not count, set threshold to zero + +isVotingAllowed :: VotingThreshold -> Bool +isVotingAllowed = \case + VotingThreshold {} -> True + NoVotingThreshold -> True + NoVotingAllowed -> False + +isStakePoolVotingAllowed :: + ConwayEraPParams era => + GovAction era -> + Bool +isStakePoolVotingAllowed = + isVotingAllowed . votingStakePoolThresholdInternal pp isElectedCommittee + where + -- Information about presence of committe or values in PParams are irrelevant for + -- knowing if voting is allowed or not: + pp = emptyPParams + isElectedCommittee = False + +votingStakePoolThreshold :: ConwayEraPParams era => RatifyState era -> GovAction era -> StrictMaybe UnitInterval -thresholdSPO rSt action = - let pp = rSt ^. rsEnactStateL . ensCurPParamsL - PoolVotingThresholds +votingStakePoolThreshold ratifyState = + toRatifyVotingThreshold . votingStakePoolThresholdInternal pp isElectedCommittee + where + pp = ratifyState ^. rsEnactStateL . ensCurPParamsL + isElectedCommittee = isSJust $ ratifyState ^. rsEnactStateL . ensCommitteeL + +votingStakePoolThresholdInternal :: + ConwayEraPParams era => + PParams era -> + Bool -> + GovAction era -> + VotingThreshold +votingStakePoolThresholdInternal pp isElectedCommittee action = + let PoolVotingThresholds { pvtCommitteeNoConfidence , pvtCommitteeNormal , pvtHardForkInitiation } = pp ^. ppPoolVotingThresholdsL - committee = rSt ^. rsEnactStateL . ensCommitteeL in case action of - NoConfidence {} -> SJust pvtCommitteeNoConfidence - NewCommittee {} -> SJust $ - case committee of - SJust _ -> pvtCommitteeNormal - SNothing -> pvtCommitteeNoConfidence - NewConstitution {} -> SJust minBound - HardForkInitiation {} -> SJust pvtHardForkInitiation - ParameterChange {} -> SJust minBound - TreasuryWithdrawals {} -> SJust minBound - InfoAction {} -> SNothing - -thresholdCC :: - StrictMaybe (Committee era) -> + NoConfidence {} -> VotingThreshold pvtCommitteeNoConfidence + NewCommittee {} -> + VotingThreshold $ + if isElectedCommittee + then pvtCommitteeNormal + else pvtCommitteeNoConfidence + NewConstitution {} -> NoVotingAllowed + HardForkInitiation {} -> VotingThreshold pvtHardForkInitiation + ParameterChange {} -> NoVotingAllowed + TreasuryWithdrawals {} -> NoVotingAllowed + InfoAction {} -> NoVotingThreshold + +isCommitteeVotingAllowed :: GovAction era -> Bool +isCommitteeVotingAllowed = + isVotingAllowed . votingCommitteeThresholdInternal committee + where + -- Information about presence of committe is irrelevant for knowing if voting is + -- allowed or not + committee = SNothing + +votingCommitteeThreshold :: + RatifyState era -> GovAction era -> StrictMaybe UnitInterval -thresholdCC committee action = - let ccThreshold = committeeQuorum <$> committee - in case action of - NoConfidence {} -> SJust minBound - NewCommittee {} -> SJust minBound - NewConstitution {} -> ccThreshold - HardForkInitiation {} -> ccThreshold - ParameterChange {} -> ccThreshold - TreasuryWithdrawals {} -> ccThreshold - InfoAction {} -> SNothing - -thresholdDRep :: +votingCommitteeThreshold ratifyState = + toRatifyVotingThreshold . votingCommitteeThresholdInternal committee + where + committee = ratifyState ^. rsEnactStateL . ensCommitteeL + +votingCommitteeThresholdInternal :: + StrictMaybe (Committee era) -> + GovAction era -> + VotingThreshold +votingCommitteeThresholdInternal committee = \case + NoConfidence {} -> NoVotingAllowed + NewCommittee {} -> NoVotingAllowed + NewConstitution {} -> threshold + HardForkInitiation {} -> threshold + ParameterChange {} -> threshold + TreasuryWithdrawals {} -> threshold + InfoAction {} -> NoVotingThreshold + where + threshold = + case committeeQuorum <$> committee of + SJust t -> VotingThreshold t + SNothing -> NoVotingThreshold + +isDRepVotingAllowed :: + ConwayEraPParams era => + GovAction era -> + Bool +isDRepVotingAllowed = + isVotingAllowed . votingDRepThresholdInternal pp isElectedCommittee + where + -- Information about presence of committe or values in PParams are irrelevant for + -- knowing if voting is allowed or not: + pp = emptyPParams + isElectedCommittee = False + +votingDRepThreshold :: ConwayEraPParams era => RatifyState era -> GovAction era -> StrictMaybe UnitInterval -thresholdDRep rSt action = - let pp = rSt ^. rsEnactStateL . ensCurPParamsL - DRepVotingThresholds +votingDRepThreshold ratifyState = + toRatifyVotingThreshold . votingDRepThresholdInternal pp isElectedCommittee + where + pp = ratifyState ^. rsEnactStateL . ensCurPParamsL + isElectedCommittee = isSJust $ ratifyState ^. rsEnactStateL . ensCommitteeL + +votingDRepThresholdInternal :: + ConwayEraPParams era => + PParams era -> + Bool -> + GovAction era -> + VotingThreshold +votingDRepThresholdInternal pp isElectedCommittee action = + let DRepVotingThresholds { dvtCommitteeNoConfidence , dvtCommitteeNormal , dvtUpdateToConstitution , dvtHardForkInitiation , dvtTreasuryWithdrawal } = pp ^. ppDRepVotingThresholdsL - committee = rSt ^. rsEnactStateL . ensCommitteeL in case action of - NoConfidence {} -> SJust dvtCommitteeNoConfidence - NewCommittee {} -> SJust $ - case committee of - SJust _ -> dvtCommitteeNormal - SNothing -> dvtCommitteeNoConfidence - NewConstitution {} -> SJust dvtUpdateToConstitution - HardForkInitiation {} -> SJust dvtHardForkInitiation - ParameterChange _ ppu -> SJust $ pparamsUpdateThreshold pp ppu - TreasuryWithdrawals {} -> SJust dvtTreasuryWithdrawal - InfoAction {} -> SNothing + NoConfidence {} -> VotingThreshold dvtCommitteeNoConfidence + NewCommittee {} -> + VotingThreshold $ + if isElectedCommittee + then dvtCommitteeNormal + else dvtCommitteeNoConfidence + NewConstitution {} -> VotingThreshold dvtUpdateToConstitution + HardForkInitiation {} -> VotingThreshold dvtHardForkInitiation + ParameterChange _ ppu -> VotingThreshold $ pparamsUpdateThreshold pp ppu + TreasuryWithdrawals {} -> VotingThreshold dvtTreasuryWithdrawal + InfoAction {} -> NoVotingThreshold 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 1ee3b37b017..4d238d1b877 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs @@ -35,8 +35,8 @@ import Cardano.Ledger.Conway.Governance ( PrevGovActionIds (..), RatifyState (..), Vote (..), - thresholdDRep, - thresholdSPO, + votingDRepThreshold, + votingStakePoolThreshold, ) import Cardano.Ledger.Conway.PParams (ConwayEraPParams) import Cardano.Ledger.Conway.Rules.Enact (EnactSignal (..), EnactState (..)) @@ -108,7 +108,7 @@ spoAccepted :: GovActionState era -> Bool spoAccepted rs RatifyEnv {reStakePoolDistr = PoolDistr poolDistr} gas = - case thresholdSPO rs gasAction of + case votingStakePoolThreshold rs gasAction of -- Short circuit on zero threshold in order to avoid redundant computation. SJust r -> r == minBound || totalAcceptedStakePoolsRatio >= unboundRational r SNothing -> False @@ -146,7 +146,7 @@ spoAccepted rs RatifyEnv {reStakePoolDistr = PoolDistr poolDistr} gas = dRepAccepted :: forall era. ConwayEraPParams era => RatifyEnv era -> RatifyState era -> GovActionState era -> Bool dRepAccepted re rs GovActionState {gasDRepVotes, gasAction} = - case thresholdDRep rs gasAction of + case votingDRepThreshold rs gasAction of SJust r -> -- Short circuit on zero threshold in order to avoid redundant computation. r == minBound diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs index 96b47a801d2..509ea50a0ba 100644 --- a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs @@ -20,7 +20,7 @@ import Cardano.Ledger.Conway.Governance ( GovActionState (..), RatifyState, Vote (..), - thresholdDRep, + votingDRepThreshold, ) import Cardano.Ledger.Conway.PParams (ConwayEraPParams) import Cardano.Ledger.Conway.Rules ( @@ -162,7 +162,7 @@ drepsPropNoStake = env {reDRepDistr = Map.empty} st gas - `shouldBe` thresholdDRep @era st (gasAction gas) + `shouldBe` votingDRepThreshold @era st (gasAction gas) == SJust minBound )