Improve ImpTest helpers

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

@@ -34,5 +34,4 @@ spec = do
   describe "AllegraImpSpec" . withEachEraVersion @era $
     UtxowSpec.spec
 
-instance EraSpecificSpec AllegraEra where
-  eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec
+instance EraSpecificSpec AllegraEra

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

@@ -41,6 +41,8 @@ instance ShelleyEraImp AllegraEra where
   fixupTx = shelleyFixupTx
   expectTxSuccess = impShelleyExpectTxSuccess
   modifyImpInitProtVer = shelleyModifyImpInitProtVer
+  genRegTxCert = shelleyGenRegTxCert
+  genUnRegTxCert = shelleyGenUnRegTxCert
 
 impAllegraSatisfyNativeScript ::
   ( ShelleyEraImp era

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

@@ -27,7 +27,6 @@ import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec as Utxow
 import Test.Cardano.Ledger.Alonzo.ImpTest
 import Test.Cardano.Ledger.Imp.Common
 import qualified Test.Cardano.Ledger.Mary.Imp as MaryImp
-import qualified Test.Cardano.Ledger.Shelley.Imp.PoolSpec as ShelleyImp
 
 spec ::
   forall era.
@@ -64,4 +63,4 @@ alonzoEraSpecificSpec = do
       Utxow.alonzoEraSpecificSpec
 
 instance EraSpecificSpec AlonzoEra where
-  eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec >> alonzoEraSpecificSpec
+  eraSpecificSpec = alonzoEraSpecificSpec

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs

@@ -10,6 +10,7 @@
 
 module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Valid (spec, alonzoEraSpecificSpec) where
 
+import Cardano.Ledger.Address
 import Cardano.Ledger.Allegra.Scripts (
   pattern RequireTimeExpire,
  )
@@ -19,9 +20,9 @@ import Cardano.Ledger.Alonzo.Rules (
  )
 import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
 import Cardano.Ledger.Alonzo.TxWits (unTxDatsL)
-import Cardano.Ledger.BaseTypes (StrictMaybe (..), inject, natVersion)
+import Cardano.Ledger.BaseTypes (Globals (networkId), StrictMaybe (..), inject, natVersion)
 import Cardano.Ledger.Coin (Coin (..))
-import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
+import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credToText)
 import Cardano.Ledger.Mary.Value (AssetName (..), MaryValue (..), MultiAsset (..), PolicyID (..))
 import Cardano.Ledger.Plutus (
   Data (..),
@@ -35,8 +36,10 @@ import Cardano.Ledger.Shelley.Scripts (
   pattern RequireSignature,
  )
 import qualified Data.Map.Strict as Map
+import qualified Data.Sequence.Strict as SSeq
+import qualified Data.Text as T
 import GHC.Exts (fromList)
-import Lens.Micro ((%~), (&), (.~))
+import Lens.Micro (to, (%~), (&), (.~))
 import Lens.Micro.Mtl (use)
 import qualified PlutusLedgerApi.Common as P
 import Test.Cardano.Ledger.Alonzo.ImpTest
@@ -87,6 +90,21 @@ spec = describe "Valid transactions" $ do
             mkBasicTx $
               mkBasicTxBody & inputsTxBodyL .~ [txIn]
 
+        it "Validating CERT script" $ do
+          txIn <- produceScript alwaysSucceedsWithDatumHash
+          txCert <- genRegTxCert $ ScriptHashObj alwaysSucceedsNoDatumHash
+          submitTx_ $
+            mkBasicTx $
+              mkBasicTxBody
+                & inputsTxBodyL .~ [txIn]
+                & certsTxBodyL .~ [txCert]
+
+        it "Validating WITHDRAWAL script" $ do
+          account <- registerStakeCredential $ ScriptHashObj alwaysSucceedsNoDatumHash
+          submitTx_ $
+            mkBasicTx $
+              mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]
+
         it "Validating MINT script" $ do
           submitTx_ =<< mkTokenMintingTx alwaysSucceedsNoDatumHash
 
@@ -132,15 +150,6 @@ alonzoEraSpecificSpec = do
           alwaysFailsWithDatumHash = hashPlutusScript $ alwaysFailsWithDatum slang :: ScriptHash
           alwaysFailsNoDatumHash = hashPlutusScript $ alwaysFailsNoDatum slang :: ScriptHash
 
-        it "Validating CERT script" $ do
-          txIn <- produceScript alwaysSucceedsWithDatumHash
-          let txCert = RegTxCert $ ScriptHashObj alwaysSucceedsNoDatumHash
-          submitTx_ $
-            mkBasicTx $
-              mkBasicTxBody
-                & inputsTxBodyL .~ [txIn]
-                & certsTxBodyL .~ [txCert]
-
         it "Not validating CERT script" $ do
           txIn <- produceScript alwaysFailsWithDatumHash
           let txCert = RegTxCert $ ScriptHashObj alwaysSucceedsNoDatumHash
@@ -150,14 +159,8 @@ alonzoEraSpecificSpec = do
                 & inputsTxBodyL .~ [txIn]
                 & certsTxBodyL .~ [txCert]
 
-        it "Validating WITHDRAWAL script" $ do
-          account <- registerStakeCredential $ ScriptHashObj alwaysSucceedsNoDatumHash
-          submitTx_ $
-            mkBasicTx $
-              mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]
-
         it "Not validating WITHDRAWAL script" $ do
-          account <- registerStakeCredential $ ScriptHashObj alwaysFailsNoDatumHash
+          account <- registerStakeCredentialNoDeposit $ ScriptHashObj alwaysFailsNoDatumHash
           submitPhase2Invalid_ $
             mkBasicTx $
               mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]
@@ -183,7 +186,7 @@ alonzoEraSpecificSpec = do
             rewardScriptHashes = [alwaysSucceedsNoDatumHash, timelockScriptHash2]
           txIns <- traverse produceScript inputScriptHashes
           multiAsset <- MultiAsset . fromList <$> traverse scriptAsset assetScriptHashes
-          rewardAccounts <- traverse (registerStakeCredential . ScriptHashObj) rewardScriptHashes
+          rewardAccounts <- traverse (registerStakeCredentialNoDeposit . ScriptHashObj) rewardScriptHashes
           outputAddr <- freshKeyHash @'Payment
           let
             txOut =
@@ -215,3 +218,15 @@ alonzoEraSpecificSpec = do
             else
               -- Conway fixed the bug that was causing DELEG to fail
               submitTx_ tx
+  where
+    -- NOTE: certain tests somehow require certificates without deposits
+    -- otherwise, they will yield a Plutus failure
+    -- TODO: figure out what's the problem, this might be of interest:
+    -- https://github.com/IntersectMBO/cardano-ledger/issues/4571
+    registerStakeCredentialNoDeposit cred = do
+      submitTxAnn_ ("Register Reward Account: " <> T.unpack (credToText cred)) $
+        mkBasicTx mkBasicTxBody
+          & bodyTxL . certsTxBodyL
+            .~ SSeq.fromList [RegTxCert cred]
+      nId <- use (impGlobalsL . to networkId)
+      pure $ RewardAccount nId cred

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

@@ -432,6 +432,8 @@ instance ShelleyEraImp AlonzoEra where
   fixupTx = alonzoFixupTx
   expectTxSuccess = impAlonzoExpectTxSuccess
   modifyImpInitProtVer = shelleyModifyImpInitProtVer
+  genRegTxCert = shelleyGenRegTxCert
+  genUnRegTxCert = shelleyGenUnRegTxCert
 
 instance MaryEraImp AlonzoEra
 

eras/babbage/impl/CHANGELOG.md

@@ -1,9 +1,13 @@
 # Version history for `cardano-ledger-babbage`
 
-## 1.12.0.1
+## 1.12.1.0
 
 *
 
+### `testlib`
+
+* Removed `babbageEraSpecificSpec`
+
 ## 1.12.0.0
 
 * Hide `Cardano.Ledger.Babbage.Translation` module

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

@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name: cardano-ledger-babbage
-version: 1.12.0.1
+version: 1.12.1.0
 license: Apache-2.0
 maintainer: [email protected]
 author: IOHK

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

@@ -6,7 +6,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Test.Cardano.Ledger.Babbage.Imp (spec, babbageEraSpecificSpec) where
+module Test.Cardano.Ledger.Babbage.Imp (spec) where
 
 import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
 import Cardano.Ledger.Alonzo.Rules (
@@ -15,7 +15,7 @@ import Cardano.Ledger.Alonzo.Rules (
   AlonzoUtxowPredFailure,
  )
 import Cardano.Ledger.Babbage (BabbageEra)
-import Cardano.Ledger.Babbage.Core (BabbageEraTxBody, InjectRuleFailure, ShelleyEraTxCert)
+import Cardano.Ledger.Babbage.Core (BabbageEraTxBody, InjectRuleFailure)
 import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure)
 import Cardano.Ledger.Babbage.TxInfo (BabbageContextError)
 import Cardano.Ledger.BaseTypes (Inject)
@@ -30,7 +30,6 @@ import qualified Test.Cardano.Ledger.Babbage.Imp.UtxoSpec as Utxo
 import qualified Test.Cardano.Ledger.Babbage.Imp.UtxosSpec as Utxos
 import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
 import Test.Cardano.Ledger.Imp.Common
-import qualified Test.Cardano.Ledger.Shelley.Imp.PoolSpec as ShelleyImp
 
 spec ::
   forall era.
@@ -56,20 +55,6 @@ spec = do
       Utxow.spec
       Utxos.spec @era
 
-babbageEraSpecificSpec ::
-  forall era.
-  ( AlonzoEraImp era
-  , ShelleyEraTxCert era
-  , BabbageEraTxBody era
-  ) =>
-  SpecWith (ImpInit (LedgerSpec era))
-babbageEraSpecificSpec = do
-  describe "Babbage era specific Imp spec" $
-    describe "Certificates without deposits" $
-      describe "UTXOW" Utxow.babbageEraSpecificSpec
-
 instance EraSpecificSpec BabbageEra where
   eraSpecificSpec =
-    ShelleyImp.shelleyEraSpecificSpec
-      >> AlonzoImp.alonzoEraSpecificSpec
-      >> babbageEraSpecificSpec
+    AlonzoImp.alonzoEraSpecificSpec

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxowSpec.hs

@@ -4,11 +4,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Test.Cardano.Ledger.Babbage.Imp.UtxowSpec (spec, babbageEraSpecificSpec) where
+module Test.Cardano.Ledger.Babbage.Imp.UtxowSpec (spec) where
 
 import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
 import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure, AlonzoUtxowPredFailure)
-import Cardano.Ledger.Babbage.Core (BabbageEraTxBody, InjectRuleFailure, ShelleyEraTxCert)
+import Cardano.Ledger.Babbage.Core (BabbageEraTxBody, InjectRuleFailure)
 import Cardano.Ledger.Babbage.Rules (BabbageUtxowPredFailure)
 import Cardano.Ledger.Babbage.TxInfo (BabbageContextError)
 import Cardano.Ledger.BaseTypes (Inject)
@@ -33,14 +33,3 @@ spec = do
   describe "UTXOW" $ do
     Valid.spec
     Invalid.spec
-
-babbageEraSpecificSpec ::
-  forall era.
-  ( AlonzoEraImp era
-  , BabbageEraTxBody era
-  , ShelleyEraTxCert era
-  ) =>
-  SpecWith (ImpInit (LedgerSpec era))
-babbageEraSpecificSpec = do
-  describe "UTXOW - certificates without deposits" $ do
-    Valid.babbageEraSpecificSpec

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxowSpec/Valid.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Test.Cardano.Ledger.Babbage.Imp.UtxowSpec.Valid (spec, babbageEraSpecificSpec) where
+module Test.Cardano.Ledger.Babbage.Imp.UtxowSpec.Valid (spec) where
 
 import Cardano.Ledger.Alonzo.TxWits (unTxDatsL)
 import Cardano.Ledger.Babbage.Core
@@ -171,17 +171,6 @@ spec = describe "Valid" $ do
                 & bodyTxL . inputsTxBodyL .~ [txInAt 0 txInitial]
                 & bodyTxL . referenceInputsTxBodyL .~ [txInAt 1 txInitial]
 
-babbageEraSpecificSpec ::
-  forall era.
-  ( AlonzoEraImp era
-  , BabbageEraTxBody era
-  , ShelleyEraTxCert era
-  ) =>
-  SpecWith (ImpInit (LedgerSpec era))
-babbageEraSpecificSpec = describe "Valid" $ do
-  forM_ @[] [PlutusV2 .. eraMaxLanguage @era] $ \slang -> do
-    describe (show slang) $ do
-      withSLanguage slang $ \lang -> do
         it "Use a reference script to authorize a delegation certificate" $ do
           addr <- freshKeyAddr_
           plutus <- mkPlutusScript $ alwaysSucceedsNoDatum lang
@@ -196,9 +185,10 @@ babbageEraSpecificSpec = describe "Valid" $ do
             submitTx $
               mkBasicTx mkBasicTxBody
                 & bodyTxL . outputsTxBodyL .~ [txOut, txOutRef]
+          cert <- genRegTxCert $ ScriptHashObj $ hashScript script
           submitTx_ $
             mkBasicTx mkBasicTxBody
               & bodyTxL . inputsTxBodyL .~ [txInAt 0 txInitial]
               & bodyTxL . referenceInputsTxBodyL .~ [txInAt 1 txInitial]
               & bodyTxL . certsTxBodyL
-                .~ [RegTxCert . ScriptHashObj $ hashScript script]
+                .~ [cert]

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

@@ -54,6 +54,8 @@ instance ShelleyEraImp BabbageEra where
   fixupTx = babbageFixupTx
   expectTxSuccess = impBabbageExpectTxSuccess
   modifyImpInitProtVer = shelleyModifyImpInitProtVer
+  genRegTxCert = shelleyGenRegTxCert
+  genUnRegTxCert = shelleyGenUnRegTxCert
 
 babbageFixupTx ::
   ( HasCallStack

eras/conway/impl/CHANGELOG.md

@@ -9,6 +9,10 @@
 
 ### `testlib`
 
+* Removed `regDelegToDRep`
+* Removed `registerRewardAccountWithDeposit`
+* Removed `registerPoolWithDeposit`
+* Removed `registerStakeCredentialWithDeposit`
 * Remove `conwayAccountsToUMap` corresponding to the removal of `UMap` from core.
 
 ## 1.20.0.0

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

@@ -59,7 +59,6 @@ import qualified Test.Cardano.Ledger.Conway.Imp.UtxosSpec as Utxos
 import qualified Test.Cardano.Ledger.Conway.Imp.UtxowSpec as Utxow
 import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Imp.Common
-import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp
 
 spec ::
   forall era.
@@ -157,7 +156,5 @@ conwayEraSpecificSpec = do
 
 instance EraSpecificSpec ConwayEra where
   eraSpecificSpec =
-    ShelleyImp.shelleyEraSpecificSpec
-      >> AlonzoImp.alonzoEraSpecificSpec
-      >> BabbageImp.babbageEraSpecificSpec
+    AlonzoImp.alonzoEraSpecificSpec
       >> conwayEraSpecificSpec

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

@@ -63,8 +63,8 @@ spec = do
                     ]
                 }
           )
-      (registeredRwdAccount, reward, _stakeKey2) <-
-        setupRewardAccount (Coin 1_000_000) DRepAlwaysNoConfidence
+      (registeredRwdAccount, reward, stakeKey2) <- setupRewardAccount
+      void $ delegateToDRep (KeyHashObj stakeKey2) (Coin 1_000_000) DRepAlwaysNoConfidence
       let
         tx =
           mkBasicTx $
@@ -95,8 +95,10 @@ spec = do
       modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
       pv <- getsPParams @era ppProtocolVersionL
 
-      (rwdAccount1, reward1, _stakeKey1) <- setupRewardAccount (Coin 1_000_000) DRepAlwaysAbstain
-      (rwdAccount2, reward2, _stakeKey2) <- setupRewardAccount (Coin 1_000_000) DRepAlwaysAbstain
+      (rwdAccount1, reward1, stakeKey1) <- setupRewardAccount
+      (rwdAccount2, reward2, stakeKey2) <- setupRewardAccount
+      void $ delegateToDRep (KeyHashObj stakeKey1) (Coin 1_000_000) DRepAlwaysAbstain
+      void $ delegateToDRep (KeyHashObj stakeKey2) (Coin 1_000_000) DRepAlwaysAbstain
       submitFailingTx
         ( mkBasicTx $
             mkBasicTxBody
@@ -127,11 +129,10 @@ spec = do
             $ Withdrawals [(rwdAccount1, zero)]
         ]
   where
-    setupRewardAccount stake dRep = do
+    setupRewardAccount = do
       kh <- freshKeyHash
       let cred = KeyHashObj kh
-      void $ regDelegToDRep cred stake dRep
-      ra <- getRewardAccountFor cred
+      ra <- registerStakeCredential cred
       submitAndExpireProposalToMakeReward cred
       b <- getBalance cred
       pure (ra, b, kh)