Skip to content

Commit 3913110

Browse files
SoupstrawSoupstraw
committed
Added postEpochBoundaryHook
Also update the pulser when modifying the protocol version in Conway
1 parent 693218d commit 3913110

File tree

14 files changed

+260
-116
lines changed

14 files changed

+260
-116
lines changed

‎eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ instance ShelleyEraImp AllegraEra where
4242

4343
fixupTx = shelleyFixupTx
4444
expectTxSuccess = impShelleyExpectTxSuccess
45+
modifyImpInitProtVer = shelleyModifyImpInitProtVer
4546

4647
impAllegraSatisfyNativeScript ::
4748
( AllegraEraScript era

‎eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -428,6 +428,7 @@ instance ShelleyEraImp AlonzoEra where
428428
impSatisfyNativeScript = impAllegraSatisfyNativeScript
429429
fixupTx = alonzoFixupTx
430430
expectTxSuccess = impAlonzoExpectTxSuccess
431+
modifyImpInitProtVer = shelleyModifyImpInitProtVer
431432

432433
instance MaryEraImp AlonzoEra
433434

‎eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -53,6 +53,7 @@ instance ShelleyEraImp BabbageEra where
5353
impSatisfyNativeScript = impAllegraSatisfyNativeScript
5454
fixupTx = babbageFixupTx
5555
expectTxSuccess = impBabbageExpectTxSuccess
56+
modifyImpInitProtVer = shelleyModifyImpInitProtVer
5657

5758
babbageFixupTx ::
5859
( HasCallStack

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -175,6 +175,7 @@ library testlib
175175

176176
build-depends:
177177
FailT,
178+
ImpSpec,
178179
aeson,
179180
base,
180181
bytestring,

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -516,7 +516,7 @@ spec = do
516516
setProtVer initialProtVer
517517
pure res
518518
(khSPO, _, _) <- setupPoolWithStake $ Coin 10_000_000
519-
-- Using an irrefutable pattern here to prevent evaluation of tuple
519+
-- Using a lazy pattern match here to prevent evaluation of tuple
520520
-- unless we actually need a value from it
521521
~(drepCred, _, _) <-
522522
if initialProtVer > bootstrapVer

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs‎

Lines changed: 69 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@
2121
module Test.Cardano.Ledger.Conway.ImpTest (
2222
module Test.Cardano.Ledger.Babbage.ImpTest,
2323
ConwayEraImp,
24+
conwayModifyImpInitProtVer,
2425
enactConstitution,
2526
enactTreasuryWithdrawals,
2627
submitGovAction,
@@ -140,9 +141,11 @@ import Cardano.Ledger.Allegra.Scripts (Timelock)
140141
import Cardano.Ledger.BaseTypes (
141142
EpochInterval (..),
142143
EpochNo (..),
144+
ProtVer (..),
143145
ShelleyBase,
144146
StrictMaybe (..),
145147
UnitInterval,
148+
Version,
146149
addEpochInterval,
147150
binOpEpochNo,
148151
inject,
@@ -222,6 +225,7 @@ import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
222225
import Test.Cardano.Ledger.Imp.Common
223226
import Test.Cardano.Ledger.Plutus (testingCostModel)
224227
import Test.Cardano.Ledger.Plutus.Guardrail (guardrailScript)
228+
import Test.ImpSpec
225229

226230
-- | Modify the PParams in the current state with the given function
227231
conwayModifyPParams ::
@@ -297,6 +301,24 @@ instance ShelleyEraImp ConwayEra where
297301

298302
fixupTx = babbageFixupTx
299303
expectTxSuccess = impBabbageExpectTxSuccess
304+
modifyImpInitProtVer = conwayModifyImpInitProtVer
305+
306+
conwayModifyImpInitProtVer ::
307+
forall era.
308+
ConwayEraImp era =>
309+
Version ->
310+
SpecWith (ImpInit (LedgerSpec era)) ->
311+
SpecWith (ImpInit (LedgerSpec era))
312+
conwayModifyImpInitProtVer ver =
313+
modifyImpInit $ \impInit ->
314+
impInit
315+
{ impInitState =
316+
impInitState impInit
317+
& impNESL . nesEsL . curPParamsEpochStateL . ppProtocolVersionL .~ ProtVer ver 0
318+
& impNESL . nesEsL %~ (\es -> setCompleteDRepPulsingState def (ratifyState es) es)
319+
}
320+
where
321+
ratifyState es = def & rsEnactStateL .~ mkEnactState (es ^. epochStateGovStateL)
300322

301323
instance MaryEraImp ConwayEra
302324

@@ -439,7 +461,7 @@ setupSingleDRep ::
439461
ConwayEraImp era =>
440462
Integer ->
441463
ImpTestM era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
442-
setupSingleDRep stake = do
464+
setupSingleDRep stake = impAnn "Set up a single DRep" $ do
443465
drepKH <- registerDRep
444466
delegatorKH <- freshKeyHash
445467
deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
@@ -488,7 +510,7 @@ setupPoolWithStake ::
488510
(ShelleyEraImp era, ConwayEraTxCert era) =>
489511
Coin ->
490512
ImpTestM era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
491-
setupPoolWithStake delegCoin = do
513+
setupPoolWithStake delegCoin = impAnn "Set up pool with stake" $ do
492514
khPool <- freshKeyHash
493515
registerPool khPool
494516
credDelegatorPayment <- KeyHashObj <$> freshKeyHash
@@ -584,22 +606,23 @@ trySubmitVote ::
584606
GovActionId ->
585607
ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
586608
trySubmitVote vote voter gaId =
587-
fmap (bimap fst txIdTx) $
588-
trySubmitTx $
589-
mkBasicTx mkBasicTxBody
590-
& bodyTxL . votingProceduresTxBodyL
591-
.~ VotingProcedures
592-
( Map.singleton
593-
voter
594-
( Map.singleton
595-
gaId
596-
( VotingProcedure
597-
{ vProcVote = vote
598-
, vProcAnchor = SNothing
599-
}
600-
)
601-
)
602-
)
609+
impAnn ("Submitting vote (" <> show vote <> ")") $
610+
fmap (bimap fst txIdTx) $
611+
trySubmitTx $
612+
mkBasicTx mkBasicTxBody
613+
& bodyTxL . votingProceduresTxBodyL
614+
.~ VotingProcedures
615+
( Map.singleton
616+
voter
617+
( Map.singleton
618+
gaId
619+
( VotingProcedure
620+
{ vProcVote = vote
621+
, vProcAnchor = SNothing
622+
}
623+
)
624+
)
625+
)
603626

604627
submitProposal_ ::
605628
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
@@ -1215,7 +1238,7 @@ registerCommitteeHotKey ::
12151238
(ShelleyEraImp era, ConwayEraTxCert era) =>
12161239
Credential 'ColdCommitteeRole ->
12171240
ImpTestM era (Credential 'HotCommitteeRole)
1218-
registerCommitteeHotKey coldKey = do
1241+
registerCommitteeHotKey coldKey = impAnn "Register committee hot key" $ do
12191242
hotKey NE.:| [] <- registerCommitteeHotKeys (KeyHashObj <$> freshKeyHash) $ pure coldKey
12201243
pure hotKey
12211244

@@ -1291,33 +1314,36 @@ electBasicCommittee ::
12911314
, GovPurposeId 'CommitteePurpose
12921315
)
12931316
electBasicCommittee = do
1294-
logString "Setting up a DRep"
12951317
(drep, _, _) <- setupSingleDRep 1_000_000
1318+
logString $ "Registered DRep: " <> showExpr drep
1319+
12961320
(spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000
1321+
logString $ "Registered SPO: " <> showExpr spoC
12971322

1298-
logString "Registering committee member"
1299-
coldCommitteeC <- KeyHashObj <$> freshKeyHash
1300-
startEpochNo <- getsNES nesELL
1301-
let
1302-
committeeAction =
1303-
UpdateCommittee
1304-
SNothing
1305-
mempty
1306-
(Map.singleton coldCommitteeC (addEpochInterval startEpochNo (EpochInterval 10)))
1307-
(1 %! 2)
1308-
(gaidCommitteeProp NE.:| _) <-
1309-
submitGovActions
1310-
[ committeeAction
1311-
, UpdateCommittee SNothing mempty mempty (1 %! 10)
1312-
]
1313-
submitYesVote_ (DRepVoter drep) gaidCommitteeProp
1314-
submitYesVote_ (StakePoolVoter spoC) gaidCommitteeProp
1315-
passNEpochs 2
1316-
committeeMembers <- getCommitteeMembers
1317-
impAnn "The committee should be enacted" $
1318-
committeeMembers `shouldSatisfy` Set.member coldCommitteeC
1319-
hotCommitteeC <- registerCommitteeHotKey coldCommitteeC
1320-
pure (drep, hotCommitteeC, GovPurposeId gaidCommitteeProp)
1323+
impAnn "Registering committee member" $ do
1324+
coldCommitteeC <- KeyHashObj <$> freshKeyHash
1325+
startEpochNo <- getsNES nesELL
1326+
let
1327+
committeeAction =
1328+
UpdateCommittee
1329+
SNothing
1330+
mempty
1331+
(Map.singleton coldCommitteeC (addEpochInterval startEpochNo (EpochInterval 10)))
1332+
(1 %! 2)
1333+
(gaidCommitteeProp NE.:| _) <-
1334+
impAnn "Submitting UpdateCommittee action" $
1335+
submitGovActions
1336+
[ committeeAction
1337+
, UpdateCommittee SNothing mempty mempty (1 %! 10)
1338+
]
1339+
submitYesVote_ (DRepVoter drep) gaidCommitteeProp
1340+
submitYesVote_ (StakePoolVoter spoC) gaidCommitteeProp
1341+
passNEpochs 2
1342+
committeeMembers <- getCommitteeMembers
1343+
impAnn "The committee should be enacted" $
1344+
committeeMembers `shouldSatisfy` Set.member coldCommitteeC
1345+
hotCommitteeC <- registerCommitteeHotKey coldCommitteeC
1346+
pure (drep, hotCommitteeC, GovPurposeId gaidCommitteeProp)
13211347

13221348
logCurPParams ::
13231349
( EraGov era

‎eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -53,6 +53,7 @@ instance ShelleyEraImp DijkstraEra where
5353

5454
fixupTx = babbageFixupTx
5555
expectTxSuccess = impBabbageExpectTxSuccess
56+
modifyImpInitProtVer = conwayModifyImpInitProtVer
5657

5758
instance MaryEraImp DijkstraEra
5859

‎eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ instance ShelleyEraImp MaryEra where
2727
impSatisfyNativeScript = impAllegraSatisfyNativeScript
2828
fixupTx = shelleyFixupTx
2929
expectTxSuccess = impShelleyExpectTxSuccess
30+
modifyImpInitProtVer = shelleyModifyImpInitProtVer
3031

3132
class
3233
( ShelleyEraImp era

0 commit comments

Comments
 (0)