Merge pull request #5137 from IntersectMBO/ldan/dijkstra-certs

* Remove Shelley style certs in Dijkstra era
* Add `EraSpecificSpec` class
* Adjust and organise tests that use certificates

Resolves #4963

Author: Lucsanszky

eras/allegra/impl/CHANGELOG.md

@@ -17,6 +17,7 @@
 
 ### `testlib`
 
+* Added `EraSpecificSpec AllegraEra` instance
 * Added `Examples` module with: `ledgerExamples`, `exampleAllegraTxBody`, `exampleAllegraTxAuxData`
 * Added `Arbitrary` instance for `TransitionConfig AllegraEra`
 * Added `Era` module with `AllegraEraTest` class

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

@@ -4,23 +4,26 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Test.Cardano.Ledger.Allegra.Imp (spec) where
 
+import Cardano.Ledger.Allegra (AllegraEra)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Shelley.Rules (
   ShelleyPoolPredFailure,
   ShelleyUtxoPredFailure,
   ShelleyUtxowPredFailure,
  )
 import qualified Test.Cardano.Ledger.Allegra.Imp.UtxowSpec as UtxowSpec
+import Test.Cardano.Ledger.Allegra.ImpTest
 import Test.Cardano.Ledger.Imp.Common
 import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp
-import Test.Cardano.Ledger.Shelley.ImpTest
 
 spec ::
   forall era.
   ( ShelleyEraImp era
+  , EraSpecificSpec era
   , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
@@ -30,3 +33,6 @@ spec = do
   ShelleyImp.spec @era
   describe "AllegraImpSpec" . withEachEraVersion @era $
     UtxowSpec.spec
+
+instance EraSpecificSpec AllegraEra where
+  eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec

eras/alonzo/impl/CHANGELOG.md

@@ -54,6 +54,7 @@
 
 ### `testlib`
 
+* Added `EraSpecificSpec AlonzoEra` instance
 * Added shrinking to `AlonzoTxAuxData`, `Redeemers`, `TxDats`
 * Added `Examples` module with: `ledgerExamples`, `mkLedgerExamples`, `exampleTx`, `exampleDatum`, `exampleAlonzoGenesis`
 * Added `Twiddle` instances for Alonzo core types

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

@@ -4,9 +4,11 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Test.Cardano.Ledger.Alonzo.Imp where
 
+import Cardano.Ledger.Alonzo (AlonzoEra)
 import Cardano.Ledger.Alonzo.Core
 import Cardano.Ledger.Alonzo.Rules (
   AlonzoUtxoPredFailure,
@@ -25,11 +27,12 @@ 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.
   ( AlonzoEraImp era
-  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
+  , EraSpecificSpec era
   , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
@@ -40,8 +43,25 @@ spec ::
   Spec
 spec = do
   MaryImp.spec @era
-  withEachEraVersion @era $ do
-    describe "AlonzoImpSpec" $ do
-      Utxo.spec
-      Utxos.spec
-      Utxow.spec
+  describe "AlonzoImpSpec" . withEachEraVersion @era $ do
+    Utxo.spec
+    Utxos.spec
+    Utxow.spec
+
+alonzoEraSpecificSpec ::
+  forall era.
+  ( AlonzoEraImp era
+  , ShelleyEraTxCert era
+  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+alonzoEraSpecificSpec = do
+  describe "Alonzo era specific Imp spec" $
+    describe "Certificates without deposits" $
+      Utxow.alonzoEraSpecificSpec
+
+instance EraSpecificSpec AlonzoEra where
+  eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec >> alonzoEraSpecificSpec

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

@@ -5,9 +5,9 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec (spec) where
+module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec (spec, alonzoEraSpecificSpec) where
 
-import Cardano.Ledger.Alonzo.Core (InjectRuleFailure)
+import Cardano.Ledger.Alonzo.Core
 import Cardano.Ledger.Alonzo.Rules (
   AlonzoUtxosPredFailure,
   AlonzoUtxowPredFailure,
@@ -21,7 +21,6 @@ import Test.Cardano.Ledger.Common
 spec ::
   forall era.
   ( AlonzoEraImp era
-  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
@@ -31,3 +30,18 @@ spec = do
   describe "UTXOW" $ do
     Valid.spec
     Invalid.spec
+
+alonzoEraSpecificSpec ::
+  forall era.
+  ( AlonzoEraImp era
+  , ShelleyEraTxCert era
+  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+alonzoEraSpecificSpec = do
+  describe "UTXOW" $ do
+    Valid.alonzoEraSpecificSpec
+    Invalid.alonzoEraSpecificSpec

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

@@ -7,7 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Invalid (spec) where
+module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Invalid (spec, alonzoEraSpecificSpec) where
 
 import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..))
 import Cardano.Ledger.Alonzo (AlonzoEra)
@@ -73,7 +73,6 @@ spec = describe "Invalid transactions" $ do
       describe (show lang) $ do
         let redeemerSameAsDatumHash = hashPlutusScript $ redeemerSameAsDatum slang
             alwaysSucceedsWithDatumHash = hashPlutusScript $ alwaysSucceedsWithDatum slang
-            alwaysSucceedsNoDatumHash = hashPlutusScript $ alwaysSucceedsNoDatum slang
 
         it "MissingRedeemers" $ do
           let scriptHash = redeemerSameAsDatumHash
@@ -156,25 +155,6 @@ spec = describe "Invalid transactions" $ do
             then submitPhase2Invalid_ tx
             else submitFailingTx tx [injectFailure $ UnspendableUTxONoDatumHash [txIn]]
 
-        it "No ExtraRedeemers on same script certificates" $ do
-          Positive n <- arbitrary
-          replicateM_ n $ freshKeyHash >>= registerPool
-          pools <- getsNES $ nesEsL . epochStateStakePoolsL
-          poolId <- elements $ Map.keys pools
-          let scriptHash = alwaysSucceedsNoDatumHash
-              cred = ScriptHashObj scriptHash
-              certs =
-                [ mkRegTxCert cred
-                , mkDelegStakeTxCert cred poolId
-                , mkUnRegTxCert cred
-                ]
-          tx <- submitTx $ mkBasicTx (mkBasicTxBody & certsTxBodyL .~ certs)
-          let redeemers = tx ^. witsTxL . rdmrsTxWitsL . unRedeemersL
-          Map.keys redeemers
-            `shouldBe` [ mkCertifyingPurpose $ AsIx 1
-                       , mkCertifyingPurpose $ AsIx 2
-                       ]
-
         it "Missing phase-2 script witness" $ do
           let scriptHash = alwaysSucceedsWithDatumHash
           txIn <- produceScript scriptHash
@@ -252,6 +232,43 @@ spec = describe "Invalid transactions" $ do
             it "Spending" $
               testPurpose (mkSpendingPurpose $ AsIx 99)
 
+alonzoEraSpecificSpec ::
+  forall era.
+  ( AlonzoEraImp era
+  , ShelleyEraTxCert era
+  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+alonzoEraSpecificSpec = describe "Invalid transactions" $ do
+  forM_ (eraLanguages @era) $ \lang ->
+    withSLanguage lang $ \slang ->
+      describe (show lang) $ do
+        let alwaysSucceedsWithDatumHash = hashPlutusScript $ alwaysSucceedsWithDatum slang
+            alwaysSucceedsNoDatumHash = hashPlutusScript $ alwaysSucceedsNoDatum slang
+
+        it "No ExtraRedeemers on same script certificates" $ do
+          Positive n <- arbitrary
+          replicateM_ n $ freshKeyHash >>= registerPool
+          pools <- getsNES $ nesEsL . epochStateStakePoolsL
+          poolId <- elements $ Map.keys pools
+          let scriptHash = alwaysSucceedsNoDatumHash
+              cred = ScriptHashObj scriptHash
+              certs =
+                [ mkRegTxCert cred
+                , mkDelegStakeTxCert cred poolId
+                , mkUnRegTxCert cred
+                ]
+          tx <- submitTx $ mkBasicTx (mkBasicTxBody & certsTxBodyL .~ certs)
+          let redeemers = tx ^. witsTxL . rdmrsTxWitsL . unRedeemersL
+          Map.keys redeemers
+            `shouldBe` [ mkCertifyingPurpose $ AsIx 1
+                       , mkCertifyingPurpose $ AsIx 2
+                       ]
+
+        -- Post-Alonzo eras produce additional post-Alonzo predicate failures that we can't include here
+        unless (lang > eraMaxLanguage @AlonzoEra) $ do
+          describe "Extra Redeemer" $ do
             it "Multiple equal plutus-locked certs" $ do
               let scriptHash = alwaysSucceedsWithDatumHash
               Positive n <- arbitrary

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

@@ -8,7 +8,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Valid (spec) where
+module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Valid (spec, alonzoEraSpecificSpec) where
 
 import Cardano.Ledger.Allegra.Scripts (
   pattern RequireTimeExpire,
@@ -47,7 +47,6 @@ import Test.Cardano.Ledger.Plutus.Examples
 spec ::
   forall era.
   ( AlonzoEraImp era
-  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
   ) =>
   SpecWith (ImpInit (LedgerSpec era))
@@ -88,6 +87,51 @@ spec = describe "Valid transactions" $ do
             mkBasicTx $
               mkBasicTxBody & inputsTxBodyL .~ [txIn]
 
+        it "Validating MINT script" $ do
+          submitTx_ =<< mkTokenMintingTx alwaysSucceedsNoDatumHash
+
+        it "Not validating MINT script" $ do
+          submitPhase2Invalid_ =<< mkTokenMintingTx alwaysFailsNoDatumHash
+
+        it "Acceptable supplementary datum" $ do
+          inputAddr <- freshKeyHash @'Payment
+          amount <- Coin <$> choose (2_000_000, 8_000_000)
+          txIn <- sendCoinTo (mkAddr inputAddr StakeRefNull) amount
+          let
+            datum = Data (P.I 123)
+            datumHash = hashData datum
+            txOut =
+              mkBasicTxOut
+                (mkAddr alwaysSucceedsWithDatumHash StakeRefNull)
+                (MaryValue amount mempty)
+                & dataHashTxOutL .~ SJust datumHash
+            txBody =
+              mkBasicTxBody
+                & inputsTxBodyL .~ [txIn]
+                & outputsTxBodyL .~ [txOut]
+            tx =
+              mkBasicTx txBody
+                & witsTxL . datsTxWitsL . unTxDatsL %~ Map.insert datumHash datum
+          submitTx_ tx
+
+alonzoEraSpecificSpec ::
+  forall era.
+  ( AlonzoEraImp era
+  , ShelleyEraTxCert era
+  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+alonzoEraSpecificSpec = do
+  forM_ (eraLanguages @era) $ \lang ->
+    withSLanguage lang $ \slang ->
+      describe (show lang) $ do
+        let
+          alwaysSucceedsWithDatumHash = hashPlutusScript $ alwaysSucceedsWithDatum slang :: ScriptHash
+          alwaysSucceedsNoDatumHash = hashPlutusScript $ alwaysSucceedsNoDatum slang :: ScriptHash
+          alwaysFailsWithDatumHash = hashPlutusScript $ alwaysFailsWithDatum slang :: ScriptHash
+          alwaysFailsNoDatumHash = hashPlutusScript $ alwaysFailsNoDatum slang :: ScriptHash
+
         it "Validating CERT script" $ do
           txIn <- produceScript alwaysSucceedsWithDatumHash
           let txCert = RegTxCert $ ScriptHashObj alwaysSucceedsNoDatumHash
@@ -118,12 +162,6 @@ spec = describe "Valid transactions" $ do
             mkBasicTx $
               mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]
 
-        it "Validating MINT script" $ do
-          submitTx_ =<< mkTokenMintingTx alwaysSucceedsNoDatumHash
-
-        it "Not validating MINT script" $ do
-          submitPhase2Invalid_ =<< mkTokenMintingTx alwaysFailsNoDatumHash
-
         --  Process a transaction with a succeeding script in every place possible,
         --  and also with succeeding timelock scripts.
         it "Validating scripts everywhere" $ do
@@ -162,27 +200,6 @@ spec = describe "Valid transactions" $ do
                 & outputsTxBodyL .~ [txOut]
           submitTx_ $ mkBasicTx txBody
 
-        it "Acceptable supplementary datum" $ do
-          inputAddr <- freshKeyHash @'Payment
-          amount <- Coin <$> choose (2_000_000, 8_000_000)
-          txIn <- sendCoinTo (mkAddr inputAddr StakeRefNull) amount
-          let
-            datum = Data (P.I 123)
-            datumHash = hashData datum
-            txOut =
-              mkBasicTxOut
-                (mkAddr alwaysSucceedsWithDatumHash StakeRefNull)
-                (MaryValue amount mempty)
-                & dataHashTxOutL .~ SJust datumHash
-            txBody =
-              mkBasicTxBody
-                & inputsTxBodyL .~ [txIn]
-                & outputsTxBodyL .~ [txOut]
-            tx =
-              mkBasicTx txBody
-                & witsTxL . datsTxWitsL . unTxDatsL %~ Map.insert datumHash datum
-          submitTx_ tx
-
         it "Multiple identical certificates" $ do
           let scriptHash = alwaysSucceedsNoDatumHash
           void . registerStakeCredential $ ScriptHashObj scriptHash

eras/babbage/impl/CHANGELOG.md

@@ -18,6 +18,7 @@
 
 ### `testlib`
 
+* Added `EraSpecificSpec BabbageEra` instance
 * Added `Examples` module with: `ledgerExamples`, `exampleBabbageNewEpochState`, `exampleCollateralOutput`
 * Added `Twiddle` instances for Babbage core types
 * Added `TxInfoSpec` (moved from `cardano-ledger-babbage-test`)