Plutus preprocessor Maybe

Author: Soupstraw

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

@@ -76,6 +76,7 @@ import Cardano.Ledger.Plutus (
   Prices (..),
   SLanguage (..),
   ScriptResult (..),
+  fromSLanguage,
   hashData,
   hashPlutusScript,
  )
@@ -93,6 +94,7 @@ import Data.MapExtras (fromElems)
 import Data.Maybe (catMaybes, isJust, isNothing)
 import Data.Set (Set, (\\))
 import qualified Data.Set as Set
+import qualified Data.Text as T
 import Lens.Micro
 import Lens.Micro.Mtl (use)
 import qualified PlutusLedgerApi.Common as P
@@ -276,13 +278,24 @@ fixupDatums tx = impAnn "fixupDatums" $ do
     collectDatums :: PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
     collectDatums purpose = do
       let txIn = unAsItem <$> toSpendingPurpose (hoistPlutusPurpose toAsItem purpose)
-      txOut <- traverse (impGetUTxO @era) txIn
-      pure $ getData =<< txOut
-
-    getData :: TxOut era -> Maybe (Data era)
-    getData txOut = case txOut ^. datumTxOutF of
-      DatumHash _dh -> spendDatum <$> Map.lookup (txOutScriptHash txOut) (scriptTestContexts @era)
-      _ -> Nothing
+      mbyTxOut <- traverse (impGetUTxO @era) txIn
+      case mbyTxOut of
+        Just txOut -> getData txOut
+        Nothing -> pure Nothing
+
+    getData :: TxOut era -> ImpTestM era (Maybe (Data era))
+    getData txOut =
+      let sh = txOutScriptHash txOut
+       in case txOut ^. datumTxOutF of
+            DatumHash _dh -> case Map.lookup sh (scriptTestContexts @era) of
+              Just x -> pure . Just $ spendDatum x
+              Nothing -> do
+                logText $
+                  "Script not found in `scriptTestContexts`:\n"
+                    <> T.pack (show sh)
+                    <> "\n\nThe transaction will likely fail. To fix this, add the script to `scriptTestContexts`."
+                pure Nothing
+            _ -> pure Nothing
 
     txOutScriptHash txOut
       | Addr _ (ScriptHashObj sh) _ <- txOut ^. addrTxOutL = sh
@@ -383,7 +396,7 @@ plutusTestScripts ::
   SLanguage l ->
   Map.Map ScriptHash ScriptTestContext
 plutusTestScripts lang =
-  Map.fromList
+  Map.fromList $
     [ mkScriptTestEntry (malformedPlutus @l) $ PlutusArgs (P.I 0) (Just $ P.I 7)
     , mkScriptTestEntry (alwaysSucceedsNoDatum lang) $ PlutusArgs (P.I 0) Nothing
     , mkScriptTestEntry (alwaysSucceedsWithDatum lang) $ PlutusArgs (P.I 0) (Just $ P.I 0)
@@ -399,8 +412,10 @@ plutusTestScripts lang =
     , mkScriptTestEntry (inputsOutputsAreNotEmptyNoDatum lang) $ PlutusArgs (P.I 122) Nothing
     , mkScriptTestEntry (inputsOutputsAreNotEmptyWithDatum lang) $ PlutusArgs (P.I 222) (Just $ P.I 5)
     , mkScriptTestEntry guardrailScript $ PlutusArgs (P.I 0) Nothing
-    , mkScriptTestEntry (inputsIsSubsetOfRefInputs lang) $ PlutusArgs (P.I 0) Nothing
     ]
+      ++ [ mkScriptTestEntry (inputsOverlapsWithRefInputs lang) $ PlutusArgs (P.I 0) Nothing
+         | fromSLanguage lang >= PlutusV2
+         ]
 
 malformedPlutus :: Plutus l
 malformedPlutus = Plutus (PlutusBinary "invalid")

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

@@ -133,6 +133,7 @@ library testlib
     cardano-ledger-core:{cardano-ledger-core, testlib} >=1.13.2,
     cardano-ledger-shelley,
     cardano-strict-containers,
+    plutus-ledger-api,
     containers,
     cuddle,
     generic-random,

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs

@@ -232,9 +232,7 @@ disjointRefInputs ::
   Test (BabbageUtxoPredFailure era)
 disjointRefInputs pp inputs refInputs =
   when
-    ( pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @BabbageEra
-        && pvMajor (pp ^. ppProtocolVersionL) < natVersion @11
-    )
+    (pvMajor (pp ^. ppProtocolVersionL) == natVersion @10)
     (failureOnNonEmpty common BabbageNonDisjointRefInputs)
   where
     common = inputs `Set.intersection` refInputs

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

@@ -24,9 +24,9 @@ import Cardano.Ledger.Shelley.Rules (
  )
 import qualified Test.Cardano.Ledger.Alonzo.Imp as AlonzoImp
 import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, LedgerSpec)
+import qualified Test.Cardano.Ledger.Babbage.Imp.UtxoSpec as Utxo
 import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
 import Test.Cardano.Ledger.Imp.Common
-import qualified Test.Cardano.Ledger.Babbage.Imp.UtxoSpec as Utxo
 
 spec ::
   forall era.

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

@@ -9,6 +9,7 @@ module Test.Cardano.Ledger.Babbage.Imp.UtxoSpec (spec) where
 
 import Cardano.Ledger.Babbage.Core (
   BabbageEraTxBody (..),
+  BabbageEraTxOut (..),
   EraTx (..),
   EraTxBody (..),
   EraTxOut (..),
@@ -17,10 +18,17 @@ import Cardano.Ledger.Babbage.Core (
 import Cardano.Ledger.BaseTypes (Inject (..))
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
-import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
+import Cardano.Ledger.Plutus (
+  Data (..),
+  Datum (..),
+  SLanguage (..),
+  dataToBinaryData,
+  hashPlutusScript,
+ )
 import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set
 import Lens.Micro ((&), (.~))
+import qualified PlutusLedgerApi.V1 as PV1
 import Test.Cardano.Ledger.Babbage.ImpTest (
   AlonzoEraImp,
   ImpInit,
@@ -29,9 +37,9 @@ import Test.Cardano.Ledger.Babbage.ImpTest (
   submitTx_,
  )
 import Test.Cardano.Ledger.Common (SpecWith, describe, it)
-import Test.Cardano.Ledger.Imp.Common (mkAddr)
-import Test.Cardano.Ledger.Plutus.Examples (inputsIsSubsetOfRefInputs)
 import Test.Cardano.Ledger.Core.Utils (txInAt)
+import Test.Cardano.Ledger.Imp.Common (mkAddr)
+import Test.Cardano.Ledger.Plutus.Examples (inputsOverlapsWithRefInputs)
 
 spec :: forall era. (AlonzoEraImp era, BabbageEraTxBody era) => SpecWith (ImpInit (LedgerSpec era))
 spec = describe "UTXO" $ do
@@ -41,10 +49,11 @@ spec = describe "UTXO" $ do
         txOut =
           mkBasicTxOut
             ( mkAddr
-                (ScriptHashObj @'Payment $ hashPlutusScript (inputsIsSubsetOfRefInputs SPlutusV2))
+                (ScriptHashObj @'Payment $ hashPlutusScript (inputsOverlapsWithRefInputs SPlutusV2))
                 StakeRefNull
             )
             (inject $ Coin 1_000_000)
+            & datumTxOutL .~ (Datum . dataToBinaryData . Data . PV1.I $ 0)
       tx <-
         submitTx $
           mkBasicTx mkBasicTxBody

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

@@ -167,7 +167,6 @@ library testlib
     base,
     bytestring,
     cardano-data:{cardano-data, testlib},
-    cardano-crypto-class,
     cardano-ledger-allegra,
     cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib},
     cardano-ledger-babbage:{cardano-ledger-babbage, testlib},
@@ -186,7 +185,6 @@ library testlib
     microlens-mtl,
     mtl,
     plutus-ledger-api,
-    plutus-preprocessor,
     prettyprinter,
     small-steps >=1.1,
     text,

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

@@ -88,6 +88,7 @@ spec ::
   , ToExpr (Event (EraRule "ENACT" era))
   , Eq (Event (EraRule "ENACT" era))
   , Typeable (Event (EraRule "ENACT" era))
+  , ContextError era ~ ConwayContextError era
   ) =>
   Spec
 spec = do
@@ -123,6 +124,7 @@ conwaySpec ::
   , ToExpr (Event (EraRule "ENACT" era))
   , Eq (Event (EraRule "ENACT" era))
   , Typeable (Event (EraRule "ENACT" era))
+  , ContextError era ~ ConwayContextError era
   ) =>
   SpecWith (ImpInit (LedgerSpec era))
 conwaySpec = do

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

@@ -77,7 +77,7 @@ spec = do
 
     it "When already already registered" $ do
       expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
-      let sh = hashPlutusScript (evenRedeemerNoDatum SPlutusV3)
+      let sh = hashPlutusScript $ evenRedeemerNoDatum SPlutusV3
       let tx =
             mkBasicTx mkBasicTxBody
               & bodyTxL . certsTxBodyL

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

@@ -2,25 +2,28 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Test.Cardano.Ledger.Conway.Imp.UtxoSpec (spec) where
 
 import Cardano.Ledger.Address
+import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
+import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
+import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..))
 import Cardano.Ledger.Alonzo.Scripts
 import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
 import Cardano.Ledger.Babbage.TxBody (referenceInputsTxBodyL)
 import Cardano.Ledger.Babbage.TxOut (referenceScriptTxOutL)
 import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.PParams (ppMinFeeRefScriptCostPerByteL)
-import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
+import Cardano.Ledger.Conway.TxInfo (ConwayContextError (..))
 import Cardano.Ledger.MemoBytes (getMemoRawBytes)
 import Cardano.Ledger.Plutus.Language (
   Plutus (..),
@@ -48,11 +51,15 @@ import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Core.Rational ((%!))
 import Test.Cardano.Ledger.Core.Utils (txInAt)
 import Test.Cardano.Ledger.Imp.Common
-import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, inputsIsSubsetOfRefInputs)
+import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, inputsOverlapsWithRefInputs)
 
 spec ::
   forall era.
-  (ConwayEraImp era, InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era) =>
+  ( ConwayEraImp era
+  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
+  , ContextError era ~ ConwayContextError era
+  ) =>
   SpecWith (ImpInit (LedgerSpec era))
 spec =
   describe "Reference scripts" $ do
@@ -75,20 +82,39 @@ spec =
           ++ extraScripts
     describe "disjoint inputs and reference inputs" $ do
       let
-        scriptHash lang = hashPlutusScript (inputsIsSubsetOfRefInputs lang)
+        scriptHash lang = hashPlutusScript $ inputsOverlapsWithRefInputs lang
         tx :: TxIn -> Tx era
         tx txIn =
           mkBasicTx mkBasicTxBody
             & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
             & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
-      it "Same script cannot appear in regular and reference inputs in PlutusV3" $ do
+
+      it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 9)"
+        . whenMajorVersion @9 $ do
+        txIn <- produceScript $ scriptHash SPlutusV3
+        submitTx_ @era $ tx txIn
+      it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 10)"
+        . whenMajorVersion @10 $ do
         txIn <- produceScript $ scriptHash SPlutusV3
         submitFailingTx @era
           (tx txIn)
           [ injectFailure $
               BabbageNonDisjointRefInputs
                 (txIn NE.:| [])
           ]
+      it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 11)"
+        . whenMajorVersion @11 $ do
+        txIn <- produceScript $ scriptHash SPlutusV3
+        submitFailingTx @era
+          (tx txIn)
+          [ injectFailure $
+              CollectErrors
+                [ BadTranslation
+                    ( ReferenceInputsNotDisjointFromInputs
+                        (Set.singleton txIn)
+                    )
+                ]
+          ]
   where
     checkMinFee :: HasCallStack => NativeScript era -> [Script era] -> ImpTestM era ()
     checkMinFee scriptToSpend refScripts = do

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

@@ -32,6 +32,7 @@ import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
 import Cardano.Ledger.TxIn (TxId (..), mkTxInPartial)
 import Data.Default (def)
+import Data.Either (isLeft, isRight)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as Map
 import qualified Data.OSet.Strict as OSet
@@ -120,11 +121,17 @@ datumAndReferenceInputsSpec = do
               , mkTxInPartial producingTx 1
               ]
           & bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0)
-    submitFailingTx
-      consumingTx
-      ( pure . injectFailure . BabbageNonDisjointRefInputs $
-          mkTxInPartial producingTx 0 :| []
-      )
+    pv <- getProtVer
+    res <- trySubmitTx consumingTx
+    if pv == ProtVer (natVersion @10) 0
+      then case res of
+        Left (err, _) ->
+          err
+            `shouldBeExpr` ( pure . injectFailure . BabbageNonDisjointRefInputs $
+                              mkTxInPartial producingTx 0 :| []
+                           )
+        x -> x `shouldSatisfyExpr` isLeft
+      else res `shouldSatisfyExpr` isRight
   it "fails when using inline datums for PlutusV1" $ do
     let shSpending = hashPlutusScript (redeemerSameAsDatum SPlutusV1)
     refTxOut <- mkRefTxOut shSpending
@@ -150,22 +157,6 @@ datumAndReferenceInputsSpec = do
             CollectErrors
               [BadTranslation . inject . InlineDatumsNotSupported @era $ TxOutFromInput lockedTxIn]
         )
-  it "fails with same txIn in regular inputs and reference inputs" $ do
-    producingTx <- setupRefTx
-    let
-      consumingTx =
-        mkBasicTx mkBasicTxBody
-          & bodyTxL . inputsTxBodyL
-            .~ Set.fromList
-              [ mkTxInPartial producingTx 0
-              , mkTxInPartial producingTx 1
-              ]
-          & bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0)
-    submitFailingTx
-      consumingTx
-      ( pure . injectFailure . BabbageNonDisjointRefInputs $
-          mkTxInPartial producingTx 0 :| []
-      )
   it "fails when using inline datums for PlutusV1" $ do
     let shSpending = hashPlutusScript $ redeemerSameAsDatum SPlutusV1
     refTxOut <- mkRefTxOut shSpending