-
Notifications
You must be signed in to change notification settings - Fork 155
/
EnactSpec.hs
418 lines (383 loc) · 15.4 KB
/
EnactSpec.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Test.Cardano.Ledger.Conway.Imp.EnactSpec (spec) where
import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams
import Cardano.Ledger.Conway.Rules
import Cardano.Ledger.Credential
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Val (zero, (<->))
import Control.Monad (forM)
import Control.State.Transition.Extended (STS (..))
import Data.Default.Class (def)
import Data.Foldable (foldl', traverse_)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import qualified Data.Sequence as Seq
import Data.Word (Word64)
import Lens.Micro
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Rational
import Test.Cardano.Ledger.Imp.Common
import Type.Reflection (Typeable)
spec ::
forall era.
( ConwayEraImp era
, NFData (Event (EraRule "ENACT" era))
, ToExpr (Event (EraRule "ENACT" era))
, Eq (Event (EraRule "ENACT" era))
, Typeable (Event (EraRule "ENACT" era))
) =>
SpecWith (ImpTestState era)
spec =
describe "ENACT" $ do
treasuryWithdrawalsSpec
hardForkInitiationSpec
noConfidenceSpec
constitutionSpec
actionPrioritySpec
treasuryWithdrawalsSpec ::
forall era.
( ConwayEraImp era
, NFData (Event (EraRule "ENACT" era))
, ToExpr (Event (EraRule "ENACT" era))
, Eq (Event (EraRule "ENACT" era))
, Typeable (Event (EraRule "ENACT" era))
) =>
SpecWith (ImpTestState era)
treasuryWithdrawalsSpec =
describe "Treasury withdrawals" $ do
it "Modify EnactState as expected" $ do
rewardAcount1 <- registerRewardAccount
govActionId <- submitTreasuryWithdrawals [(rewardAcount1, Coin 666)]
gas <- getGovActionState govActionId
let govAction = gasAction gas
enactStateInit <- getEnactState
let signal =
EnactSignal
{ esGovActionId = govActionId
, esGovAction = govAction
}
enactState =
enactStateInit
{ ensTreasury = Coin 1000
}
enactState' <- runImpRule @"ENACT" () enactState signal
ensWithdrawals enactState' `shouldBe` [(raCredential rewardAcount1, Coin 666)]
rewardAcount2 <- registerRewardAccount
let withdrawals' =
[ (rewardAcount1, Coin 111)
, (rewardAcount2, Coin 222)
]
govActionId' <- submitTreasuryWithdrawals withdrawals'
gas' <- getGovActionState govActionId'
let govAction' = gasAction gas'
let signal' =
EnactSignal
{ esGovActionId = govActionId'
, esGovAction = govAction'
}
enactState'' <- runImpRule @"ENACT" () enactState' signal'
ensWithdrawals enactState''
`shouldBe` [ (raCredential rewardAcount1, Coin 777)
, (raCredential rewardAcount2, Coin 222)
]
ensTreasury enactState'' `shouldBe` Coin 1
it "Withdrawals exceeding treasury submitted in a single proposal" $ do
(drepC, committeeC, _) <- electBasicCommittee
modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 5
initialTreasury <- getTreasury
numWithdrawals <- choose (1, 10)
withdrawals <- genWithdrawalsExceeding initialTreasury numWithdrawals
void $ enactTreasuryWithdrawals withdrawals drepC committeeC
checkNoWithdrawal initialTreasury withdrawals
let sumRequested = foldMap snd withdrawals
impAnn "Submit a treasury donation that can cover the withdrawals" $ do
let tx =
mkBasicTx mkBasicTxBody
& bodyTxL . treasuryDonationTxBodyL .~ (sumRequested <-> initialTreasury)
submitTx_ tx
passNEpochs 2
getTreasury `shouldReturn` zero
sumRewardAccounts withdrawals `shouldReturn` sumRequested
it "Withdrawals exceeding maxBound Word64 submitted in a single proposal" $ do
(drepC, committeeC, _) <- electBasicCommittee
modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 5
initialTreasury <- getTreasury
numWithdrawals <- choose (1, 10)
withdrawals <- genWithdrawalsExceeding (Coin (fromIntegral (maxBound :: Word64))) numWithdrawals
void $ enactTreasuryWithdrawals withdrawals drepC committeeC
checkNoWithdrawal initialTreasury withdrawals
it "Withdrawals exceeding treasury submitted in several proposals within the same epoch" $ do
(drepC, committeeC, _) <- electBasicCommittee
modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 5
initialTreasury <- getTreasury
numWithdrawals <- choose (1, 10)
withdrawals <- genWithdrawalsExceeding initialTreasury numWithdrawals
impAnn "submit in individual proposals in the same epoch" $ do
traverse_
( \w -> do
gaId <- submitTreasuryWithdrawals @era [w]
submitYesVote_ (DRepVoter drepC) gaId
submitYesVote_ (CommitteeVoter committeeC) gaId
)
withdrawals
passNEpochs 2
let expectedTreasury =
foldl'
( \acc (_, x) ->
if acc >= x
then acc <-> x
else acc
)
initialTreasury
withdrawals
getTreasury `shouldReturn` expectedTreasury
-- check that the sum of the rewards matches what was spent from the treasury
sumRewardAccounts withdrawals `shouldReturn` (initialTreasury <-> expectedTreasury)
where
getTreasury = getsNES (nesEsL . esAccountStateL . asTreasuryL)
sumRewardAccounts withdrawals = mconcat <$> traverse (getRewardAccountAmount . fst) withdrawals
genWithdrawalsExceeding (Coin val) n = do
vals <- genValuesExceeding val n
forM (Coin <$> vals) $ \coin -> (,coin) <$> registerRewardAccount
checkNoWithdrawal initialTreasury withdrawals = do
getTreasury `shouldReturn` initialTreasury
sumRewardAccounts withdrawals `shouldReturn` zero
genValuesExceeding val n = do
pcts <- replicateM (n - 1) $ choose (1, 100)
let tot = sum pcts
let amounts = map (\x -> ceiling ((x * val) % tot)) pcts
let minNeeded = max 0 (val - sum amounts + 1)
excess <- choose (minNeeded, val + 1)
pure $ excess : amounts
hardForkInitiationSpec :: ConwayEraImp era => SpecWith (ImpTestState era)
hardForkInitiationSpec =
it "HardForkInitiation" $ do
(_, committeeMember, _) <- electBasicCommittee
modifyPParams $ \pp ->
pp
& ppDRepVotingThresholdsL . dvtHardForkInitiationL .~ 2 %! 3
& ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 2 %! 3
& ppGovActionLifetimeL .~ EpochInterval 20
_ <- setupPoolWithStake $ Coin 22_000_000
(stakePoolId1, _, _) <- setupPoolWithStake $ Coin 22_000_000
(stakePoolId2, _, _) <- setupPoolWithStake $ Coin 22_000_000
(dRep1, _, _) <- setupSingleDRep 11_000_000
(dRep2, _, _) <- setupSingleDRep 11_000_000
curProtVer <- getsNES $ nesEsL . curPParamsEpochStateL . ppProtocolVersionL
nextMajorVersion <- succVersion $ pvMajor curProtVer
let nextProtVer = curProtVer {pvMajor = nextMajorVersion}
govActionId <- submitGovAction $ HardForkInitiation SNothing nextProtVer
submitYesVote_ (CommitteeVoter committeeMember) govActionId
submitYesVote_ (DRepVoter (KeyHashObj dRep1)) govActionId
submitYesVote_ (StakePoolVoter stakePoolId1) govActionId
passNEpochs 2
getsNES (nesEsL . curPParamsEpochStateL . ppProtocolVersionL) `shouldReturn` curProtVer
submitYesVote_ (DRepVoter (KeyHashObj dRep2)) govActionId
passNEpochs 2
getsNES (nesEsL . curPParamsEpochStateL . ppProtocolVersionL) `shouldReturn` curProtVer
submitYesVote_ (StakePoolVoter stakePoolId2) govActionId
passNEpochs 2
getsNES (nesEsL . curPParamsEpochStateL . ppProtocolVersionL) `shouldReturn` nextProtVer
noConfidenceSpec :: forall era. ConwayEraImp era => SpecWith (ImpTestState era)
noConfidenceSpec =
it "NoConfidence" $ do
modifyPParams $ \pp ->
pp
& ppDRepVotingThresholdsL . dvtCommitteeNoConfidenceL .~ 1 %! 2
& ppPoolVotingThresholdsL . pvtCommitteeNoConfidenceL .~ 1 %! 2
& ppCommitteeMaxTermLengthL .~ EpochInterval 200
let
getCommittee =
getsNES $
nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL
assertNoCommittee :: HasCallStack => ImpTestM era ()
assertNoCommittee =
do
committee <- getCommittee
impAnn "There should not be a committee" $ committee `shouldBe` SNothing
assertNoCommittee
khCC <- freshKeyHash
(drep, _, _) <- setupSingleDRep 1_000_000
let committeeMap =
Map.fromList
[ (KeyHashObj khCC, EpochNo 50)
]
prevGaidCommittee@(GovPurposeId gaidCommittee) <-
electCommittee
SNothing
drep
mempty
committeeMap
(khSPO, _, _) <- setupPoolWithStake $ Coin 42_000_000
logStakeDistr
submitYesVote_ (StakePoolVoter khSPO) gaidCommittee
replicateM_ 4 passEpoch
impAnn "Committee should be elected" $ do
committee <- getCommittee
committee `shouldBe` SJust (Committee committeeMap $ 1 %! 2)
pp <- getsNES $ nesEsL . curPParamsEpochStateL
returnAddr <- registerRewardAccount
gaidNoConf <-
submitProposal $
ProposalProcedure
{ pProcReturnAddr = returnAddr
, pProcGovAction = NoConfidence (SJust prevGaidCommittee)
, pProcDeposit = pp ^. ppGovActionDepositL
, pProcAnchor = def
}
submitYesVote_ (StakePoolVoter khSPO) gaidNoConf
submitYesVote_ (DRepVoter $ KeyHashObj drep) gaidNoConf
replicateM_ 4 passEpoch
assertNoCommittee
constitutionSpec :: ConwayEraImp era => SpecWith (ImpTestState era)
constitutionSpec =
it "Constitution" $ do
(dRep, committeeMember, _) <- electBasicCommittee
(govActionId, constitution) <- submitConstitution SNothing
proposalsBeforeVotes <- getsNES $ newEpochStateGovStateL . proposalsGovStateL
pulserBeforeVotes <- getsNES newEpochStateDRepPulsingStateL
submitYesVote_ (DRepVoter dRep) govActionId
submitYesVote_ (CommitteeVoter committeeMember) govActionId
proposalsAfterVotes <- getsNES $ newEpochStateGovStateL . proposalsGovStateL
pulserAfterVotes <- getsNES newEpochStateDRepPulsingStateL
impAnn "Votes are recorded in the proposals" $ do
let proposalsWithVotes =
proposalsAddVote
(CommitteeVoter committeeMember)
VoteYes
govActionId
( proposalsAddVote
(DRepVoter dRep)
VoteYes
govActionId
proposalsBeforeVotes
)
proposalsAfterVotes `shouldBe` proposalsWithVotes
impAnn "Pulser has not changed" $
pulserAfterVotes `shouldBe` pulserBeforeVotes
passEpoch
impAnn "New constitution is not enacted after one epoch" $ do
constitutionAfterOneEpoch <- getsNES $ newEpochStateGovStateL . constitutionGovStateL
constitutionAfterOneEpoch `shouldBe` def
impAnn "Pulser should reflect the constitution to be enacted" $ do
pulser <- getsNES newEpochStateDRepPulsingStateL
let ratifyState = extractDRepPulsingState pulser
gasId <$> rsEnacted ratifyState `shouldBe` govActionId Seq.:<| Seq.Empty
rsEnactState ratifyState ^. ensConstitutionL `shouldBe` constitution
passEpoch
impAnn "Constitution is enacted after two epochs" $ do
curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL
curConstitution `shouldBe` constitution
impAnn "Pulser is reset" $ do
pulser <- getsNES newEpochStateDRepPulsingStateL
let pulserRatifyState = extractDRepPulsingState pulser
rsEnacted pulserRatifyState `shouldBe` Seq.empty
enactState <- getEnactState
rsEnactState pulserRatifyState `shouldBe` enactState
actionPrioritySpec ::
forall era.
ConwayEraImp era =>
SpecWith (ImpTestState era)
actionPrioritySpec =
describe "Competing proposals ratified in the same epoch" $ do
it
"higher action priority wins"
$ do
(drepC, _, gpi) <- electBasicCommittee
(poolKH, _, _) <- setupPoolWithStake $ Coin 1_000_000
modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 5
cc <- KeyHashObj <$> freshKeyHash
gai1 <-
submitGovAction $
UpdateCommittee (SJust gpi) mempty (Map.singleton cc (EpochNo 30)) $
1 %! 2
-- gai2 is the first action of a higher priority
gai2 <- submitGovAction $ NoConfidence $ SJust gpi
gai3 <- submitGovAction $ NoConfidence $ SJust gpi
traverse_ @[]
( \gaid -> do
submitYesVote_ (DRepVoter drepC) gaid
submitYesVote_ (StakePoolVoter poolKH) gaid
)
[gai1, gai2, gai3]
passNEpochs 2
getLastEnactedCommittee
`shouldReturn` SJust (GovPurposeId gai2)
expectNoCurrentProposals
committee <-
getsNES $
nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL
committee `shouldBe` SNothing
let val1 = Coin 1_000_001
let val2 = Coin 1_000_002
let val3 = Coin 1_000_003
it "proposals of same priority are enacted in order of submission" $ do
(drepC, committeeC, _) <- electBasicCommittee
modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 5
pGai0 <-
submitParameterChange
SNothing
$ def & ppuDRepDepositL .~ SJust val1
pGai1 <-
submitParameterChange
(SJust $ GovPurposeId pGai0)
$ def & ppuDRepDepositL .~ SJust val2
pGai2 <-
submitParameterChange
(SJust $ GovPurposeId pGai1)
$ def & ppuDRepDepositL .~ SJust val3
traverse_ @[]
( \gaid -> do
submitYesVote_ (DRepVoter drepC) gaid
submitYesVote_ (CommitteeVoter committeeC) gaid
)
[pGai0, pGai1, pGai2]
passNEpochs 2
getLastEnactedParameterChange
`shouldReturn` SJust (GovPurposeId pGai2)
expectNoCurrentProposals
getsNES (nesEsL . curPParamsEpochStateL . ppDRepDepositL)
`shouldReturn` val3
it "only the first action of a transaction gets enacted" $ do
(drepC, committeeC, _) <- electBasicCommittee
modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 5
gaids <-
submitGovActions $
NE.fromList
[ ParameterChange
SNothing
(def & ppuDRepDepositL .~ SJust val1)
SNothing
, ParameterChange
SNothing
(def & ppuDRepDepositL .~ SJust val2)
SNothing
, ParameterChange
SNothing
(def & ppuDRepDepositL .~ SJust val3)
SNothing
]
traverse_
( \gaid -> do
submitYesVote_ (DRepVoter drepC) gaid
submitYesVote_ (CommitteeVoter committeeC) gaid
)
gaids
passNEpochs 2
getsNES (nesEsL . curPParamsEpochStateL . ppDRepDepositL)
`shouldReturn` val1
expectNoCurrentProposals