Added postEpochBoundaryHook

Also update the pulser when modifying the protocol version in Conway

Co-authored-by: teodanciu <[email protected]>

Author: Soupstraw

cabal.project

@@ -16,7 +16,7 @@ source-repository-package
   subdir: hs
   -- !WARNING!:
   -- MAKE SURE THIS POINTS TO A COMMIT IN `*-artifacts` BEFORE MERGE!
-  tag: d419ed67d4e5a5aa7b26f22785dd7b64f08de37a
+  tag: 33cc4c0dccad41875ccb46749983d4b2c38bffe9
 
 source-repository-package
   type: git

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

@@ -42,6 +42,7 @@ instance ShelleyEraImp AllegraEra where
 
   fixupTx = shelleyFixupTx
   expectTxSuccess = impShelleyExpectTxSuccess
+  modifyImpInitProtVer = shelleyModifyImpInitProtVer
 
 impAllegraSatisfyNativeScript ::
   ( AllegraEraScript era

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

@@ -431,6 +431,7 @@ instance ShelleyEraImp AlonzoEra where
   impSatisfyNativeScript = impAllegraSatisfyNativeScript
   fixupTx = alonzoFixupTx
   expectTxSuccess = impAlonzoExpectTxSuccess
+  modifyImpInitProtVer = shelleyModifyImpInitProtVer
 
 instance MaryEraImp AlonzoEra
 

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

@@ -53,6 +53,7 @@ instance ShelleyEraImp BabbageEra where
   impSatisfyNativeScript = impAllegraSatisfyNativeScript
   fixupTx = babbageFixupTx
   expectTxSuccess = impBabbageExpectTxSuccess
+  modifyImpInitProtVer = shelleyModifyImpInitProtVer
 
 babbageFixupTx ::
   ( HasCallStack

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

@@ -176,6 +176,7 @@ library testlib
 
   build-depends:
     FailT,
+    ImpSpec,
     aeson,
     base,
     bytestring,

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

@@ -490,7 +490,7 @@ spec = do
           setProtVer initialProtVer
           pure res
         (khSPO, _, _) <- setupPoolWithStake $ Coin 10_000_000
-        -- Using an irrefutable pattern here to prevent evaluation of tuple
+        -- Using a lazy pattern match here to prevent evaluation of tuple
         -- unless we actually need a value from it
         ~(drepCred, _, _) <-
           if initialProtVer > bootstrapVer

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

@@ -21,6 +21,7 @@
 module Test.Cardano.Ledger.Conway.ImpTest (
   module Test.Cardano.Ledger.Babbage.ImpTest,
   ConwayEraImp,
+  conwayModifyImpInitProtVer,
   enactConstitution,
   enactTreasuryWithdrawals,
   submitGovAction,
@@ -144,9 +145,11 @@ import Cardano.Ledger.Allegra.Scripts (Timelock)
 import Cardano.Ledger.BaseTypes (
   EpochInterval (..),
   EpochNo (..),
+  ProtVer (..),
   ShelleyBase,
   StrictMaybe (..),
   UnitInterval,
+  Version,
   addEpochInterval,
   binOpEpochNo,
   inject,
@@ -228,6 +231,7 @@ import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
 import Test.Cardano.Ledger.Imp.Common
 import Test.Cardano.Ledger.Plutus (testingCostModel)
 import Test.Cardano.Ledger.Plutus.Guardrail (guardrailScript)
+import Test.ImpSpec
 
 -- | Modify the PParams in the current state with the given function
 conwayModifyPParams ::
@@ -303,6 +307,24 @@ instance ShelleyEraImp ConwayEra where
 
   fixupTx = babbageFixupTx
   expectTxSuccess = impBabbageExpectTxSuccess
+  modifyImpInitProtVer = conwayModifyImpInitProtVer
+
+conwayModifyImpInitProtVer ::
+  forall era.
+  ConwayEraImp era =>
+  Version ->
+  SpecWith (ImpInit (LedgerSpec era)) ->
+  SpecWith (ImpInit (LedgerSpec era))
+conwayModifyImpInitProtVer ver =
+  modifyImpInit $ \impInit ->
+    impInit
+      { impInitState =
+          impInitState impInit
+            & impNESL . nesEsL . curPParamsEpochStateL . ppProtocolVersionL .~ ProtVer ver 0
+            & impNESL . nesEsL %~ (\es -> setCompleteDRepPulsingState def (ratifyState es) es)
+      }
+  where
+    ratifyState es = def & rsEnactStateL .~ mkEnactState (es ^. epochStateGovStateL)
 
 instance MaryEraImp ConwayEra
 
@@ -446,7 +468,7 @@ setupSingleDRep ::
   ConwayEraImp era =>
   Integer ->
   ImpTestM era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
-setupSingleDRep stake = do
+setupSingleDRep stake = impAnn "Set up a single DRep" $ do
   drepKH <- registerDRep
   kh <- freshKeyHash
   (delegatorKH, spendingKP) <-
@@ -512,7 +534,7 @@ setupPoolWithStake ::
   ConwayEraImp era =>
   Coin ->
   ImpTestM era (KeyHash 'StakePool, Credential 'Payment, Credential 'Staking)
-setupPoolWithStake delegCoin = do
+setupPoolWithStake delegCoin = impAnn "Set up pool with stake" $ do
   khPool <- freshKeyHash
   registerPoolWithDeposit khPool
   credDelegatorPayment <- KeyHashObj <$> freshKeyHash
@@ -608,22 +630,23 @@ trySubmitVote ::
   GovActionId ->
   ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) TxId)
 trySubmitVote vote voter gaId =
-  fmap (bimap fst txIdTx) $
-    trySubmitTx $
-      mkBasicTx mkBasicTxBody
-        & bodyTxL . votingProceduresTxBodyL
-          .~ VotingProcedures
-            ( Map.singleton
-                voter
-                ( Map.singleton
-                    gaId
-                    ( VotingProcedure
-                        { vProcVote = vote
-                        , vProcAnchor = SNothing
-                        }
-                    )
-                )
-            )
+  impAnn ("Submitting vote (" <> show vote <> ")") $
+    fmap (bimap fst txIdTx) $
+      trySubmitTx $
+        mkBasicTx mkBasicTxBody
+          & bodyTxL . votingProceduresTxBodyL
+            .~ VotingProcedures
+              ( Map.singleton
+                  voter
+                  ( Map.singleton
+                      gaId
+                      ( VotingProcedure
+                          { vProcVote = vote
+                          , vProcAnchor = SNothing
+                          }
+                      )
+                  )
+              )
 
 submitProposal_ ::
   (ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
@@ -1230,7 +1253,7 @@ registerCommitteeHotKey ::
   (ShelleyEraImp era, ConwayEraTxCert era) =>
   Credential 'ColdCommitteeRole ->
   ImpTestM era (Credential 'HotCommitteeRole)
-registerCommitteeHotKey coldKey = do
+registerCommitteeHotKey coldKey = impAnn "Register committee hot key" $ do
   hotKey NE.:| [] <- registerCommitteeHotKeys (KeyHashObj <$> freshKeyHash) $ pure coldKey
   pure hotKey
 
@@ -1306,33 +1329,36 @@ electBasicCommittee ::
     , GovPurposeId 'CommitteePurpose
     )
 electBasicCommittee = do
-  logString "Setting up a DRep"
   (drep, _, _) <- setupSingleDRep 1_000_000
+  logString $ "Registered DRep: " <> showExpr drep
+
   (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000
+  logString $ "Registered SPO: " <> showExpr spoC
 
-  logString "Registering committee member"
-  coldCommitteeC <- KeyHashObj <$> freshKeyHash
-  startEpochNo <- getsNES nesELL
-  let
-    committeeAction =
-      UpdateCommittee
-        SNothing
-        mempty
-        (Map.singleton coldCommitteeC (addEpochInterval startEpochNo (EpochInterval 10)))
-        (1 %! 2)
-  (gaidCommitteeProp NE.:| _) <-
-    submitGovActions
-      [ committeeAction
-      , UpdateCommittee SNothing mempty mempty (1 %! 10)
-      ]
-  submitYesVote_ (DRepVoter drep) gaidCommitteeProp
-  submitYesVote_ (StakePoolVoter spoC) gaidCommitteeProp
-  passNEpochs 2
-  committeeMembers <- getCommitteeMembers
-  impAnn "The committee should be enacted" $
-    committeeMembers `shouldSatisfy` Set.member coldCommitteeC
-  hotCommitteeC <- registerCommitteeHotKey coldCommitteeC
-  pure (drep, hotCommitteeC, GovPurposeId gaidCommitteeProp)
+  impAnn "Registering committee member" $ do
+    coldCommitteeC <- KeyHashObj <$> freshKeyHash
+    startEpochNo <- getsNES nesELL
+    let
+      committeeAction =
+        UpdateCommittee
+          SNothing
+          mempty
+          (Map.singleton coldCommitteeC (addEpochInterval startEpochNo (EpochInterval 10)))
+          (1 %! 2)
+    (gaidCommitteeProp NE.:| _) <-
+      impAnn "Submitting UpdateCommittee action" $
+        submitGovActions
+          [ committeeAction
+          , UpdateCommittee SNothing mempty mempty (1 %! 10)
+          ]
+    submitYesVote_ (DRepVoter drep) gaidCommitteeProp
+    submitYesVote_ (StakePoolVoter spoC) gaidCommitteeProp
+    passNEpochs 2
+    committeeMembers <- getCommitteeMembers
+    impAnn "The committee should be enacted" $
+      committeeMembers `shouldSatisfy` Set.member coldCommitteeC
+    hotCommitteeC <- registerCommitteeHotKey coldCommitteeC
+    pure (drep, hotCommitteeC, GovPurposeId gaidCommitteeProp)
 
 logCurPParams ::
   ( EraGov era

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

@@ -55,6 +55,7 @@ instance ShelleyEraImp DijkstraEra where
 
   fixupTx = babbageFixupTx
   expectTxSuccess = impBabbageExpectTxSuccess
+  modifyImpInitProtVer = conwayModifyImpInitProtVer
 
 instance MaryEraImp DijkstraEra
 

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

@@ -27,6 +27,7 @@ instance ShelleyEraImp MaryEra where
   impSatisfyNativeScript = impAllegraSatisfyNativeScript
   fixupTx = shelleyFixupTx
   expectTxSuccess = impShelleyExpectTxSuccess
+  modifyImpInitProtVer = shelleyModifyImpInitProtVer
 
 class
   ( ShelleyEraImp era