diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index fbed51ad6df..9968d538170 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -113,7 +113,10 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test - other-modules: Test.Cardano.Ledger.Conway.BinarySpec + other-modules: + Test.Cardano.Ledger.Conway.BinarySpec + Test.Cardano.Ledger.Conway.RatifySpec + default-language: Haskell2010 ghc-options: -Wall -Wcompat -Wincomplete-record-updates @@ -125,4 +128,6 @@ test-suite tests cardano-ledger-core:testlib, cardano-ledger-alonzo, cardano-ledger-conway, + cardano-ledger-core, + containers, testlib 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 8f9a34e0435..343b5d1f005 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs @@ -16,6 +16,8 @@ module Cardano.Ledger.Conway.Rules.Ratify ( RatifyState (..), RatifyEnv (..), RatifySignal (..), + dRepAccepted, + dRepAcceptedRatio, ) where import Cardano.Ledger.BaseTypes (ShelleyBase) @@ -31,7 +33,7 @@ import Cardano.Ledger.Conway.Governance ( ) import Cardano.Ledger.Conway.Rules.Enact (EnactPredFailure, EnactState (..)) import Cardano.Ledger.Core -import Cardano.Ledger.Credential (Credential) +import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Keys (KeyRole (..)) import Cardano.Ledger.PoolDistr (PoolDistr (..), individualPoolStake) import Cardano.Ledger.Slot (EpochNo (..)) @@ -47,9 +49,10 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Monoid (Sum (..)) -import Data.Ratio ((%)) +import Data.Ratio (Ratio, (%)) import Data.Sequence.Strict (StrictSeq (..)) import Data.Void (absurd) +import Data.Word (Word64) data RatifyEnv era = RatifyEnv { reStakeDistr :: !(Map (Credential 'Staking (EraCrypto era)) Coin) @@ -93,11 +96,14 @@ instance spoThreshold :: Rational spoThreshold = 51 % 100 +dRepThreshold :: Ratio Word64 +dRepThreshold = 0 + epochsToExpire :: EpochNo epochsToExpire = 30 -accepted :: RatifyEnv era -> GovActionState era -> Bool -accepted RatifyEnv {reStakePoolDistr = PoolDistr poolDistr} gas = +spoAccepted :: RatifyEnv era -> GovActionState era -> Bool +spoAccepted RatifyEnv {reStakePoolDistr = PoolDistr poolDistr} gas = totalAcceptedStakePoolsRatio > getStakePoolThreshold gasAction where GovActionState {gasStakePoolVotes, gasAction} = gas @@ -135,6 +141,51 @@ accepted RatifyEnv {reStakePoolDistr = PoolDistr poolDistr} gas = HardForkInitiation {} -> 101 % 100 _ -> spoThreshold +dRepAccepted :: forall era. RatifyEnv era -> GovActionState era -> Bool +dRepAccepted RatifyEnv {reDRepDistr} GovActionState {gasDRepVotes, gasAction} = + case dRepAcceptedRatio reDRepDistr gasDRepVotes gasAction of + Nothing -> True -- TODO: change this when we are ready to consider dReps on sanchonet + Just ratio -> ratio >= dRepThreshold + +-- Compute the dRep ratio yes/(yes + no), where +-- yes: is the total stake of +-- - registered dReps that voted 'yes', plus +-- - the AlwaysNoConfidence dRep, in case the action is NoConfidence +-- no: is the total stake of +-- - registered dReps that voted 'no', plus +-- - registered dReps that did not vote for this action, plus +-- - the AlwaysNoConfidence dRep +-- In other words, the denominator `yes + no` is the total stake of all registered dReps, minus the abstain votes stake +-- (both credential DReps and AlwaysAbstain) +-- +-- We iterate over the dRep distribution, and incrementally construct the numerator and denominator. +dRepAcceptedRatio :: + forall era. + Map (DRep (EraCrypto era)) (CompactForm Coin) -> + Map (Credential 'DRepRole (EraCrypto era)) Vote -> + GovAction era -> + Maybe (Ratio Word64) +dRepAcceptedRatio reDRepDistr gasDRepVotes gasAction + | totalExcludingAbstainStake == 0 = Nothing + | otherwise = Just (yesStake % totalExcludingAbstainStake) + where + accumStake :: (Word64, Word64) -> DRep (EraCrypto era) -> CompactForm Coin -> (Word64, Word64) + accumStake (yes, tot) drep (CompactCoin stake) = + case drep of + DRepCredential cred -> + case Map.lookup cred gasDRepVotes of + Nothing -> (yes, tot + stake) + Just VoteYes -> (yes + stake, tot + stake) + Just Abstain -> (yes, tot) + Just VoteNo -> (yes, tot + stake) + DRepAlwaysNoConfidence -> + case gasAction of + NoConfidence _ -> (yes + stake, tot + stake) + _ -> (yes, tot + stake) + DRepAlwaysAbstain -> (yes, tot) + + (yesStake, totalExcludingAbstainStake) = Map.foldlWithKey accumStake (0, 0) reDRepDistr + ratifyTransition :: forall era. ( Embed (EraRule "ENACT" era) (ConwayRATIFY era) @@ -155,7 +206,7 @@ ratifyTransition = do case rsig of act@(_, ast@GovActionState {gasAction, gasProposedIn}) :<| sigs -> do let expired = gasProposedIn + epochsToExpire < reCurrentEpoch - if accepted env ast + if spoAccepted env ast && dRepAccepted env ast then do -- Update ENACT state with the governance action that was ratified es <- trans @(EraRule "ENACT" era) $ TRC ((), rsEnactState, gasAction) diff --git a/eras/conway/impl/test/Main.hs b/eras/conway/impl/test/Main.hs index e4d1cd57d96..1e97c97966a 100644 --- a/eras/conway/impl/test/Main.hs +++ b/eras/conway/impl/test/Main.hs @@ -2,9 +2,11 @@ module Main where import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Conway.BinarySpec as BinarySpec +import qualified Test.Cardano.Ledger.Conway.RatifySpec as RatifySpec main :: IO () main = ledgerTestMain $ describe "Conway" $ do BinarySpec.spec + RatifySpec.spec diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs new file mode 100644 index 00000000000..111200d481a --- /dev/null +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Conway.RatifySpec (spec) where + +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) +import Cardano.Ledger.Conway +import Cardano.Ledger.Conway.Governance ( + GovAction (..), + Vote (..), + ) +import Cardano.Ledger.Conway.Rules +import Cardano.Ledger.Core +import Data.Foldable (fold) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Ratio ((%)) +import qualified Data.Set as Set +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Conway.Arbitrary () +import Test.Cardano.Ledger.Core.Arbitrary () + +spec :: Spec +spec = do + describe "Ratification" $ do + drepsProp @Conway + +drepsProp :: forall era. Era era => Spec +drepsProp = + prop "DRep vote counts" $ + forAll (arbitrary @(Map (DRep (EraCrypto era)) (CompactForm Coin))) $ + \dRepDistr -> do + forAll (shuffle (Map.keys dRepDistr)) $ \dreps -> do + let size = fromIntegral $ length dreps + yes = ratio (30 :: Integer) size + drepsYes = onlyDrepsCred $ take yes dreps + votesYes = Map.fromList $ [(cred, VoteYes) | DRepCredential cred <- drepsYes] + CompactCoin stakeYes = fold $ Map.restrictKeys dRepDistr (Set.fromList drepsYes) + + no = ratio 40 size + drepsNo = onlyDrepsCred $ take no . drop yes $ dreps + votesNo = Map.fromList $ [(cred, VoteNo) | DRepCredential cred <- drepsNo] + CompactCoin stakeNo = fold $ Map.restrictKeys dRepDistr (Set.fromList drepsNo) + + abstain = ratio 10 size + drepsAbstain = onlyDrepsCred $ take abstain . drop (yes + no) $ dreps + votesAbstain = Map.fromList [(cred, Abstain) | DRepCredential cred <- drepsAbstain] + CompactCoin stakeAbstain = fold $ Map.restrictKeys dRepDistr (Set.fromList drepsAbstain) + + CompactCoin stakeAlwaysAbstain = fromMaybe (CompactCoin 0) $ Map.lookup DRepAlwaysAbstain dRepDistr + CompactCoin stakeAlwaysNoConfidence = fromMaybe (CompactCoin 0) $ Map.lookup DRepAlwaysNoConfidence dRepDistr + CompactCoin notVotedStake = + fold $ + Map.withoutKeys + dRepDistr + (Set.fromList (drepsYes ++ drepsNo ++ drepsAbstain ++ [DRepAlwaysAbstain, DRepAlwaysNoConfidence])) + + votes = Map.union votesYes $ Map.union votesNo votesAbstain + + CompactCoin totalStake = fold dRepDistr + + actual = dRepAcceptedRatio @era dRepDistr votes InfoAction + expected + | totalStake == stakeAbstain + stakeAlwaysAbstain = Nothing + | otherwise = Just $ stakeYes % (totalStake - stakeAbstain - stakeAlwaysAbstain) + + actual `shouldBe` expected + + let expectedRephrased + | stakeYes + stakeNo + notVotedStake + stakeAlwaysNoConfidence == 0 = Nothing + | otherwise = Just $ stakeYes % (stakeYes + stakeNo + notVotedStake + stakeAlwaysNoConfidence) + actual `shouldBe` expectedRephrased + + let actualNoConfidence = dRepAcceptedRatio @era dRepDistr votes (NoConfidence SNothing) + expectedNoConfidence + | totalStake == stakeAbstain + stakeAlwaysAbstain = Nothing + | otherwise = Just $ (stakeYes + stakeAlwaysNoConfidence) % (totalStake - stakeAbstain - stakeAlwaysAbstain) + actualNoConfidence `shouldBe` expectedNoConfidence + where + ratio pct tot = ceiling $ (pct * tot) % 100 + onlyDrepsCred l = + filter + ( \case + DRepCredential _ -> True + _ -> False + ) + l