Skip to content

Commit 81a39af

Browse files
LucsanszkyLucsanszky
authored
Merge pull request #4700 from IntersectMBO/ldan/spo-voting-tests
Test SPO vote counting Follow-up for #4659 Resolves #4617, #4727
2 parents 242cdd5 + 214fef4 commit 81a39af

File tree

6 files changed

+602
-0
lines changed

6 files changed

+602
-0
lines changed

‎eras/conway/impl/CHANGELOG.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88

99
### `testlib`
1010

11+
* Added `delegateSPORewardAddressToDRep_`
1112
* Add `mkUpdateCommitteeProposal`
1213
* Add `SubmitFailureExpectation`, `FailBoth`, `submitBootstrapAwareFailingVote`, `submitBootstrapAwareFailingProposal`, `submitBootstrapAwareFailingProposal_`
1314
* Add `mkConstitutionProposal`

‎eras/conway/impl/cardano-ledger-conway.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -225,6 +225,7 @@ test-suite tests
225225
Test.Cardano.Ledger.Conway.GenesisSpec
226226
Test.Cardano.Ledger.Conway.GovActionReorderSpec
227227
Test.Cardano.Ledger.Conway.Plutus.PlutusSpec
228+
Test.Cardano.Ledger.Conway.SPORatifySpec
228229
Test.Cardano.Ledger.Conway.TxInfoSpec
229230
Test.Cardano.Ledger.Conway.GoldenTranslation
230231
Paths_cardano_ledger_conway
@@ -238,6 +239,7 @@ test-suite tests
238239
build-depends:
239240
aeson,
240241
base,
242+
cardano-data,
241243
cardano-ledger-core:testlib,
242244
cardano-ledger-allegra,
243245
cardano-ledger-alonzo:testlib,

‎eras/conway/impl/test/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ import qualified Test.Cardano.Ledger.Conway.GovActionReorderSpec as GovActionReo
1717
import qualified Test.Cardano.Ledger.Conway.Imp as Imp
1818
import Test.Cardano.Ledger.Conway.Plutus.PlutusSpec as PlutusSpec
1919
import qualified Test.Cardano.Ledger.Conway.Proposals as Proposals
20+
import qualified Test.Cardano.Ledger.Conway.SPORatifySpec as SPORatifySpec
2021
import qualified Test.Cardano.Ledger.Conway.Spec as Spec
2122
import qualified Test.Cardano.Ledger.Conway.TxInfoSpec as TxInfo
2223
import Test.Cardano.Ledger.Core.JSON (roundTripJsonEraSpec)
@@ -32,6 +33,7 @@ main =
3233
Cddl.spec
3334
DRepRatify.spec
3435
CommitteeRatify.spec
36+
SPORatifySpec.spec
3537
Genesis.spec
3638
GovActionReorder.spec
3739
roundTripJsonEraSpec @Conway

‎eras/conway/impl/test/Test/Cardano/Ledger/Conway/SPORatifySpec.hs

Lines changed: 341 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,341 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE FlexibleInstances #-}
5+
{-# LANGUAGE MonoLocalBinds #-}
6+
{-# LANGUAGE NamedFieldPuns #-}
7+
{-# LANGUAGE RecordWildCards #-}
8+
{-# LANGUAGE ScopedTypeVariables #-}
9+
{-# LANGUAGE TypeApplications #-}
10+
11+
module Test.Cardano.Ledger.Conway.SPORatifySpec (spec) where
12+
13+
import Cardano.Ledger.Address (RewardAccount (..))
14+
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
15+
import Cardano.Ledger.Coin (Coin (..), CompactForm (..))
16+
import Cardano.Ledger.Compactible (Compactible (..))
17+
import Cardano.Ledger.Conway
18+
import Cardano.Ledger.Conway.Core
19+
import Cardano.Ledger.Conway.Governance (
20+
GovAction (..),
21+
GovActionState (..),
22+
RatifyEnv (..),
23+
RatifyState,
24+
Vote (..),
25+
ensProtVerL,
26+
gasAction,
27+
gasActionL,
28+
rsEnactStateL,
29+
votingStakePoolThreshold,
30+
)
31+
import Cardano.Ledger.Conway.Rules (
32+
spoAccepted,
33+
spoAcceptedRatio,
34+
)
35+
import Cardano.Ledger.Credential (Credential (..))
36+
import Cardano.Ledger.DRep (DRep (..))
37+
import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
38+
import Cardano.Ledger.PoolDistr (IndividualPoolStake (..), PoolDistr (..))
39+
import Cardano.Ledger.PoolParams (PoolParams, ppId, ppRewardAccount)
40+
import Cardano.Ledger.Shelley.HardForks (bootstrapPhase)
41+
import Cardano.Ledger.Val ((<+>), (<->))
42+
import Data.Functor.Identity (Identity)
43+
import Data.Map.Strict (Map)
44+
import qualified Data.Map.Strict as Map
45+
import Data.MapExtras (fromKeys)
46+
import Data.Maybe (fromJust)
47+
import Data.Ratio ((%))
48+
import Lens.Micro
49+
import Test.Cardano.Ledger.Common
50+
import Test.Cardano.Ledger.Conway.Arbitrary ()
51+
import Test.Cardano.Ledger.Core.Arbitrary ()
52+
53+
spec :: Spec
54+
spec = do
55+
describe "SPO Ratification" $ do
56+
acceptedRatioProp @Conway
57+
noStakeProp @Conway
58+
allAbstainProp @Conway
59+
noVotesProp @Conway
60+
allYesProp @Conway
61+
noConfidenceProp @Conway
62+
63+
acceptedRatioProp ::
64+
forall era.
65+
( Arbitrary (PParamsHKD StrictMaybe era)
66+
, Arbitrary (PParamsHKD Identity era)
67+
, ConwayEraPParams era
68+
) =>
69+
Spec
70+
acceptedRatioProp = do
71+
prop @((RatifyEnv era, RatifyState era, GovActionState era) -> Property)
72+
"SPO vote count for arbitrary vote ratios"
73+
$ \(re, rs, gas) -> forAll genRatios $ \ratios ->
74+
forAll
75+
(genTestData @era ratios)
76+
( \TestData {..} -> do
77+
let
78+
protVer = rs ^. rsEnactStateL . ensProtVerL
79+
actual =
80+
spoAcceptedRatio @era
81+
re {reStakePoolDistr = distr, reDelegatees = delegatees, rePoolParams = poolParams}
82+
gas {gasStakePoolVotes = votes}
83+
protVer
84+
expected =
85+
if fromCompact totalStake == stakeAbstain <+> stakeAlwaysAbstain
86+
then 0
87+
else case gas ^. gasActionL of
88+
HardForkInitiation _ _ -> unCoin stakeYes % unCoin (fromCompact totalStake <-> stakeAbstain)
89+
action
90+
| bootstrapPhase protVer ->
91+
unCoin stakeYes
92+
% unCoin (fromCompact totalStake <-> stakeAbstain <-> stakeAlwaysAbstain <-> stakeNoConfidence)
93+
| NoConfidence {} <- action ->
94+
unCoin (stakeYes <+> stakeNoConfidence)
95+
% unCoin (fromCompact totalStake <-> stakeAbstain <-> stakeAlwaysAbstain)
96+
| otherwise ->
97+
unCoin stakeYes % unCoin (fromCompact totalStake <-> stakeAbstain <-> stakeAlwaysAbstain)
98+
actual `shouldBe` expected
99+
)
100+
101+
noStakeProp ::
102+
forall era.
103+
( Arbitrary (PParamsHKD StrictMaybe era)
104+
, Arbitrary (PParamsHKD Identity era)
105+
, ConwayEraPParams era
106+
) =>
107+
Spec
108+
noStakeProp =
109+
prop @((RatifyEnv era, RatifyState era, GovActionState era) -> IO ())
110+
"If there is no stake, accept iff threshold is zero"
111+
( \(re, rs, gas) ->
112+
let re' = re {reStakePoolDistr = PoolDistr Map.empty (fromJust . toCompact $ Coin 100)}
113+
in spoAccepted @era re' rs gas
114+
`shouldBe` (votingStakePoolThreshold @era rs (gasAction gas) == SJust minBound)
115+
)
116+
117+
allAbstainProp ::
118+
forall era.
119+
( Arbitrary (PParamsHKD StrictMaybe era)
120+
, Arbitrary (PParamsHKD Identity era)
121+
, ConwayEraPParams era
122+
) =>
123+
Spec
124+
allAbstainProp =
125+
prop @((RatifyEnv era, RatifyState era, GovActionState era) -> Property)
126+
"If all votes are abstain, accepted ratio is zero"
127+
$ \(re, rs, gas) -> forAll
128+
( genTestData @era
129+
(Ratios {yes = 0, no = 0, abstain = 50 % 100, alwaysAbstain = 50 % 100, noConfidence = 0})
130+
)
131+
$ \TestData {..} ->
132+
spoAcceptedRatio
133+
@era
134+
re {reStakePoolDistr = distr, reDelegatees = delegatees, rePoolParams = poolParams}
135+
gas {gasStakePoolVotes = votes}
136+
(rs ^. rsEnactStateL . ensProtVerL)
137+
`shouldBe` 0
138+
139+
noVotesProp ::
140+
forall era.
141+
( Arbitrary (PParamsHKD StrictMaybe era)
142+
, Arbitrary (PParamsHKD Identity era)
143+
, ConwayEraPParams era
144+
) =>
145+
Spec
146+
noVotesProp =
147+
prop @((RatifyEnv era, RatifyState era, GovActionState era) -> Property)
148+
"If there are no votes, accepted ratio is zero"
149+
$ \(re, rs, gas) -> forAll
150+
( genTestData @era
151+
(Ratios {yes = 0, no = 0, abstain = 0, alwaysAbstain = 0, noConfidence = 0})
152+
)
153+
$ \TestData {..} ->
154+
spoAcceptedRatio
155+
@era
156+
re {reStakePoolDistr = distr}
157+
gas {gasStakePoolVotes = votes}
158+
(rs ^. rsEnactStateL . ensProtVerL)
159+
`shouldBe` 0
160+
161+
allYesProp ::
162+
forall era.
163+
( Arbitrary (PParamsHKD StrictMaybe era)
164+
, Arbitrary (PParamsHKD Identity era)
165+
, ConwayEraPParams era
166+
) =>
167+
Spec
168+
allYesProp =
169+
prop @((RatifyEnv era, RatifyState era, GovActionState era) -> Property)
170+
"If all vote yes, accepted ratio is 1 (unless there is no stake) "
171+
( \(re, rs, gas) ->
172+
forAll
173+
( genTestData @era
174+
(Ratios {yes = 100 % 100, no = 0, abstain = 0, alwaysAbstain = 0, noConfidence = 0})
175+
)
176+
( \TestData {..} ->
177+
let acceptedRatio =
178+
spoAcceptedRatio
179+
@era
180+
re {reStakePoolDistr = distr}
181+
gas {gasStakePoolVotes = votes}
182+
(rs ^. rsEnactStateL . ensProtVerL)
183+
in if fromCompact totalStake == Coin 0
184+
then acceptedRatio `shouldBe` 0
185+
else acceptedRatio `shouldBe` 1
186+
)
187+
)
188+
189+
noConfidenceProp ::
190+
forall era.
191+
( Arbitrary (PParamsHKD StrictMaybe era)
192+
, Arbitrary (PParamsHKD Identity era)
193+
, ConwayEraPParams era
194+
) =>
195+
Spec
196+
noConfidenceProp =
197+
prop @((RatifyEnv era, RatifyState era, GovActionState era) -> Property)
198+
"If all votes are no confidence, accepted ratio is zero"
199+
$ \(re, rs, gas) -> forAll
200+
( genTestData @era
201+
(Ratios {yes = 0, no = 0, abstain = 0, alwaysAbstain = 0, noConfidence = 1 % 1})
202+
)
203+
$ \TestData {..} ->
204+
spoAcceptedRatio
205+
@era
206+
re {reStakePoolDistr = distr}
207+
gas {gasStakePoolVotes = votes}
208+
(rs ^. rsEnactStateL . ensProtVerL)
209+
`shouldBe` 0
210+
211+
data TestData era = TestData
212+
{ distr :: PoolDistr (EraCrypto era)
213+
, votes :: Map (KeyHash 'StakePool (EraCrypto era)) Vote
214+
, totalStake :: CompactForm Coin
215+
, stakeYes :: Coin
216+
, stakeNo :: Coin
217+
, stakeAbstain :: Coin
218+
, stakeAlwaysAbstain :: Coin
219+
, stakeNoConfidence :: Coin
220+
, stakeNotVoted :: Coin
221+
, delegatees :: Map (Credential 'Staking (EraCrypto era)) (DRep (EraCrypto era))
222+
, poolParams :: Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
223+
}
224+
deriving (Show)
225+
226+
data Ratios = Ratios
227+
{ yes :: Rational
228+
, no :: Rational
229+
, abstain :: Rational
230+
, alwaysAbstain :: Rational
231+
, noConfidence :: Rational
232+
}
233+
deriving (Show)
234+
235+
-- Prepare the pool distribution, votes, map of pool parameters and map of reward account delegatees
236+
-- according to the given ratios.
237+
genTestData ::
238+
forall era.
239+
Era era =>
240+
Ratios ->
241+
Gen (TestData era)
242+
genTestData Ratios {yes, no, abstain, alwaysAbstain, noConfidence} = do
243+
pools <- listOf (arbitrary @(KeyHash 'StakePool (EraCrypto era)))
244+
let (poolsYes, poolsNo, poolsAbstain, poolsAlwaysAbstain, poolsNoConfidence, rest) =
245+
splitByPct yes no abstain alwaysAbstain noConfidence pools
246+
totalStake = length pools
247+
distr <- do
248+
vrf <- arbitrary
249+
let
250+
indivStake = IndividualPoolStake (1 / toRational totalStake) (CompactCoin 1) vrf
251+
pure $
252+
PoolDistr
253+
( unionAllFromLists
254+
[ (poolsYes, indivStake)
255+
, (poolsNo, indivStake)
256+
, (poolsAbstain, indivStake)
257+
, (poolsAlwaysAbstain, indivStake)
258+
, (poolsNoConfidence, indivStake)
259+
]
260+
)
261+
(CompactCoin $ fromIntegral totalStake)
262+
263+
poolParamsAA <- genPoolParams poolsAlwaysAbstain
264+
poolParamsNC <- genPoolParams poolsNoConfidence
265+
poolParamsRest <- genPoolParams $ poolsYes <> poolsNo <> poolsAbstain
266+
let delegateesAA = mkDelegatees DRepAlwaysAbstain poolParamsAA
267+
delegateesNC = mkDelegatees DRepAlwaysNoConfidence poolParamsNC
268+
votes = unionAllFromLists [(poolsYes, VoteYes), (poolsNo, VoteNo), (poolsAbstain, Abstain)]
269+
270+
pure
271+
TestData
272+
{ distr
273+
, votes
274+
, totalStake = pdTotalActiveStake distr
275+
, stakeYes = Coin . fromIntegral $ length poolsYes
276+
, stakeNo = Coin . fromIntegral $ length poolsNo
277+
, stakeAbstain = Coin . fromIntegral $ length poolsAbstain
278+
, stakeAlwaysAbstain = Coin . fromIntegral $ length poolsAlwaysAbstain
279+
, stakeNoConfidence = Coin . fromIntegral $ length poolsNoConfidence
280+
, stakeNotVoted = Coin . fromIntegral $ length rest
281+
, delegatees = Map.union delegateesAA delegateesNC
282+
, poolParams = Map.unions [poolParamsRest, poolParamsAA, poolParamsNC]
283+
}
284+
where
285+
splitByPct ::
286+
Rational ->
287+
Rational ->
288+
Rational ->
289+
Rational ->
290+
Rational ->
291+
[a] ->
292+
([a], [a], [a], [a], [a], [a])
293+
splitByPct r1 r2 r3 r4 r5 l =
294+
let
295+
size = fromIntegral $ length l
296+
(rs1, rest) = splitAt (ceiling (r1 * size)) l
297+
(rs2, rest') = splitAt (ceiling (r2 * size)) rest
298+
(rs3, rest'') = splitAt (ceiling (r3 * size)) rest'
299+
(rs4, rest''') = splitAt (ceiling (r4 * size)) rest''
300+
(rs5, rest'''') = splitAt (ceiling (r5 * size)) rest'''
301+
in
302+
(rs1, rs2, rs3, rs4, rs5, rest'''')
303+
304+
genPoolParams p = do
305+
let genPoolParams' poolId = do
306+
poolParams <- arbitrary
307+
pure $ poolParams {ppId = poolId}
308+
sequence $ fromKeys genPoolParams' p
309+
310+
-- Given a delegatee and a map of stake pool params,
311+
-- create a map of reward account delegatees.
312+
mkDelegatees ::
313+
DRep (EraCrypto era) ->
314+
Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)) ->
315+
Map (Credential 'Staking (EraCrypto era)) (DRep (EraCrypto era))
316+
mkDelegatees drep =
317+
fromKeys (const drep) . map (raCredential . ppRewardAccount) . Map.elems
318+
319+
-- Create a map from each pool with the given value, where the key is the pool credential
320+
-- and take the union of all these maps.
321+
unionAllFromLists ::
322+
[([KeyHash 'StakePool (EraCrypto era)], a)] ->
323+
Map (KeyHash 'StakePool (EraCrypto era)) a
324+
unionAllFromLists = foldMap (\(ks, v) -> fromKeys (const v) ks)
325+
326+
genRatios :: Gen Ratios
327+
genRatios = do
328+
(a, b, c, d, e) <- genPctsOf100
329+
pure $ Ratios {yes = a, no = b, abstain = c, alwaysAbstain = d, noConfidence = e}
330+
331+
-- Generates rational values for voting ratios.
332+
genPctsOf100 :: Gen (Rational, Rational, Rational, Rational, Rational)
333+
genPctsOf100 = do
334+
a <- choose (0, 100)
335+
b <- choose (0, 100)
336+
c <- choose (0, 100)
337+
d <- choose (0, 100)
338+
e <- choose (0, 100)
339+
f <- choose (0, 100) -- stake that didn't participate
340+
let s = a + b + c + d + e + f
341+
pure (a % s, b % s, c % s, d % s, e % s)

0 commit comments

Comments
 (0)