Merge pull request #4944 from IntersectMBO/nm/alonzo-imp-utxow-valid

Implement more Alonzo UTxOW Imp tests

Author: lehins

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

@@ -13,7 +13,11 @@ import Cardano.Ledger.Alonzo.Rules (
   AlonzoUtxosPredFailure,
   AlonzoUtxowPredFailure,
  )
-import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure)
+import Cardano.Ledger.Shelley.Rules (
+  ShelleyDelegPredFailure,
+  ShelleyUtxoPredFailure,
+  ShelleyUtxowPredFailure,
+ )
 import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec as Utxo
 import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec as Utxos
 import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec as Utxow
@@ -25,6 +29,7 @@ spec ::
   forall era.
   ( Arbitrary (TxAuxData era)
   , AlonzoEraImp era
+  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era

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

@@ -14,7 +14,7 @@ import Cardano.Ledger.Alonzo.Rules (
   AlonzoUtxosPredFailure,
   AlonzoUtxowPredFailure,
  )
-import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure)
+import Cardano.Ledger.Shelley.Rules (ShelleyDelegPredFailure, ShelleyUtxowPredFailure)
 import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Invalid as Invalid
 import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Valid as Valid
 import Test.Cardano.Ledger.Alonzo.ImpTest
@@ -23,6 +23,7 @@ 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

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -17,29 +18,37 @@ import Cardano.Ledger.Alonzo.Rules (
   AlonzoUtxosPredFailure,
  )
 import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
-import Cardano.Ledger.BaseTypes (StrictMaybe (..))
+import Cardano.Ledger.Alonzo.TxWits (unTxDatsL)
+import Cardano.Ledger.BaseTypes (StrictMaybe (..), natVersion)
+import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
 import Cardano.Ledger.Mary.Value (AssetName (..), MaryValue (..), MultiAsset (..), PolicyID (..))
 import Cardano.Ledger.Plutus (
+  Data (..),
+  hashData,
   hashPlutusScript,
   withSLanguage,
  )
+import Cardano.Ledger.Shelley.Rules (ShelleyDelegPredFailure (..))
 import Cardano.Ledger.Shelley.Scripts (
   pattern RequireAllOf,
   pattern RequireSignature,
  )
 import Control.Monad ((<=<))
 import GHC.Exts (fromList)
-import Lens.Micro ((&), (.~))
+import Lens.Micro ((%~), (&), (.~))
 import Lens.Micro.Mtl (use)
-import Test.Cardano.Ledger.Alonzo.Arbitrary ()
 import Test.Cardano.Ledger.Alonzo.ImpTest
 import Test.Cardano.Ledger.Imp.Common
 import Test.Cardano.Ledger.Plutus.Examples
 
+import qualified Data.Map.Strict as Map
+import qualified PlutusLedgerApi.Common as P
+
 spec ::
   forall era.
   ( AlonzoEraImp era
+  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
   ) =>
   SpecWith (ImpInit (LedgerSpec era))
@@ -139,9 +148,42 @@ spec = describe "Valid transactions" $ do
                 & outputsTxBodyL .~ [txOut]
           expectTxSuccess <=< submitTx $ mkBasicTx txBody
 
-  it "Acceptable supplimentary datum" $ do
-    const $ pendingWith "not implemented yet"
-  it "Multiple identical certificates" $ do
-    const $ pendingWith "not implemented yet"
+        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
+          expectTxSuccess =<< submitTx tx
+
+        it "Multiple identical certificates" $ do
+          let scriptHash = alwaysSucceedsNoDatumHash
+          void . registerStakeCredential $ ScriptHashObj scriptHash
+          let tx =
+                mkBasicTx mkBasicTxBody
+                  & bodyTxL . certsTxBodyL .~ fromList (UnRegTxCert . ScriptHashObj <$> replicate 2 scriptHash)
+          if eraProtVerLow @era < natVersion @9
+            then
+              -- This passes UTXOW rules but not DELEG rules; however, we care about only UTXOW rules here
+              submitFailingTx
+                tx
+                [injectFailure $ StakeKeyNotRegisteredDELEG (ScriptHashObj scriptHash)]
+            else
+              -- Conway fixed the bug that was causing DELEG to fail
+              expectTxSuccess =<< submitTx tx
+
   it "Non-script output with datum" $ do
     const $ pendingWith "not implemented yet"

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

@@ -60,7 +60,7 @@ import Cardano.Ledger.Alonzo.Rules (
 import Cardano.Ledger.Alonzo.Scripts (plutusScriptLanguage, toAsItem, toAsIx)
 import Cardano.Ledger.Alonzo.Tx (IsValid (..), hashScriptIntegrity)
 import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData)
-import Cardano.Ledger.Alonzo.TxWits (TxDats (..), unRedeemersL)
+import Cardano.Ledger.Alonzo.TxWits (unRedeemersL, unTxDatsL)
 import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO (..), AlonzoScriptsNeeded (..))
 import Cardano.Ledger.BaseTypes (Globals (..), StrictMaybe (..))
 import Cardano.Ledger.Coin (Coin (..))
@@ -272,12 +272,10 @@ fixupDatums tx = impAnn "fixupDatums" $ do
   contexts <- impGetPlutusContexts tx
   let purposes = (^. _1) <$> contexts
   datums <- traverse collectDatums purposes
-  let TxDats prevDats = tx ^. witsTxL . datsTxWitsL
   pure $
     tx
-      & witsTxL . datsTxWitsL
-        .~ TxDats
-          (Map.union prevDats $ fromElems hashData (catMaybes datums))
+      & witsTxL . datsTxWitsL . unTxDatsL
+        <>~ fromElems hashData (catMaybes datums)
   where
     collectDatums :: PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
     collectDatums purpose = do

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

@@ -17,7 +17,11 @@ import Cardano.Ledger.Babbage.Core
 import Cardano.Ledger.Babbage.Rules (BabbageUtxowPredFailure (..))
 import Cardano.Ledger.Babbage.TxInfo (BabbageContextError)
 import Cardano.Ledger.BaseTypes (Inject)
-import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure)
+import Cardano.Ledger.Shelley.Rules (
+  ShelleyDelegPredFailure,
+  ShelleyUtxoPredFailure,
+  ShelleyUtxowPredFailure,
+ )
 import qualified Test.Cardano.Ledger.Alonzo.Imp as AlonzoImp
 import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, LedgerSpec)
 import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
@@ -28,6 +32,7 @@ spec ::
   ( Arbitrary (TxAuxData era)
   , AlonzoEraImp era
   , BabbageEraTxBody era
+  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era

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

@@ -32,6 +32,7 @@ import Cardano.Ledger.Conway.Rules (
 import Cardano.Ledger.Conway.TxInfo (ConwayContextError)
 import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..))
 import Cardano.Ledger.Shelley.Rules (
+  ShelleyDelegPredFailure,
   ShelleyUtxoPredFailure,
   ShelleyUtxowPredFailure,
  )
@@ -71,6 +72,7 @@ spec ::
   , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
   , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -169,6 +170,10 @@ import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..))
 import Cardano.Ledger.Conway.Governance
 import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams (..))
 import Cardano.Ledger.Conway.Rules (
+  ConwayCertPredFailure (..),
+  ConwayCertsPredFailure (..),
+  ConwayDelegPredFailure (..),
+  ConwayLedgerPredFailure (..),
   EnactSignal,
   committeeAccepted,
   committeeAcceptedRatio,
@@ -209,6 +214,8 @@ import Cardano.Ledger.Shelley.LedgerState (
   vsCommitteeStateL,
   vsDRepsL,
  )
+import Cardano.Ledger.Shelley.Rules (ShelleyDelegPredFailure)
+import qualified Cardano.Ledger.Shelley.Rules as Shelley
 import Cardano.Ledger.TxIn (TxId (..))
 import Cardano.Ledger.UMap (dRepMap)
 import qualified Cardano.Ledger.UMap as UMap
@@ -1817,3 +1824,16 @@ delegateSPORewardAddressToDRep_ kh stake drep = do
       (raCredential . ppRewardAccount $ pp)
       stake
       drep
+
+-- Partial implementation used for checking predicate failures
+instance InjectRuleFailure "LEDGER" ShelleyDelegPredFailure ConwayEra where
+  injectFailure = ConwayCertsFailure . injectFailure
+instance InjectRuleFailure "CERTS" ShelleyDelegPredFailure ConwayEra where
+  injectFailure = CertFailure . injectFailure
+instance InjectRuleFailure "CERT" ShelleyDelegPredFailure ConwayEra where
+  injectFailure = DelegFailure . injectFailure
+instance InjectRuleFailure "DELEG" ShelleyDelegPredFailure ConwayEra where
+  injectFailure (Shelley.StakeKeyAlreadyRegisteredDELEG c) = StakeKeyRegisteredDELEG c
+  injectFailure (Shelley.StakeKeyNotRegisteredDELEG c) = StakeKeyNotRegisteredDELEG c
+  injectFailure (Shelley.StakeKeyNonZeroAccountBalanceDELEG c) = StakeKeyHasNonZeroRewardAccountBalanceDELEG c
+  injectFailure _ = error "Cannot inject ShelleyDelegPredFailure into ConwayEra"