Disabled BabbageNonDisjointRefInputs predicate failure for PlutusV2 scripts

Author: Soupstraw

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

@@ -78,6 +78,7 @@ import Cardano.Ledger.Plutus (
   ScriptResult (..),
   hashData,
   hashPlutusScript,
+  plutusLanguage,
  )
 import Cardano.Ledger.Shelley.LedgerState (
   curPParamsEpochStateL,
@@ -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)
@@ -400,6 +413,9 @@ plutusTestScripts lang =
     , mkScriptTestEntry (inputsOutputsAreNotEmptyWithDatum lang) $ PlutusArgs (P.I 222) (Just $ P.I 5)
     , mkScriptTestEntry guardrailScript $ PlutusArgs (P.I 0) Nothing
     ]
+      ++ [ mkScriptTestEntry (inputsOverlapsWithRefInputs lang) $ PlutusArgs (P.I 0) Nothing
+         | plutusLanguage lang >= PlutusV2
+         ]
 
 malformedPlutus :: Plutus l
 malformedPlutus = Plutus (PlutusBinary "invalid")

eras/babbage/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.12.0.0
 
+* Remove `BabbageNonDisjointRefInputs` for protocol versions >10
 * Remove `BabbageTxBody`
 * Removed `era` parameter from `BabbageTxBodyRaw`
 * Move `Annotator` instances to `testlib`

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

@@ -104,6 +104,7 @@ library testlib
     Test.Cardano.Ledger.Babbage.CDDL
     Test.Cardano.Ledger.Babbage.Era
     Test.Cardano.Ledger.Babbage.Imp
+    Test.Cardano.Ledger.Babbage.Imp.UtxoSpec
     Test.Cardano.Ledger.Babbage.Imp.UtxowSpec
     Test.Cardano.Ledger.Babbage.ImpTest
     Test.Cardano.Ledger.Babbage.Translation.TranslatableGen
@@ -137,6 +138,7 @@ library testlib
     generic-random,
     heredoc,
     microlens,
+    plutus-ledger-api,
     small-steps >=1.1,
 
 executable huddle-cddl

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

@@ -24,6 +24,7 @@ module Cardano.Ledger.Babbage.Rules.Utxo (
   validateTotalCollateral,
   validateCollateralEqBalance,
   validateOutputTooSmallUTxO,
+  disjointRefInputs,
 ) where
 
 import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure, shelleyToAllegraUtxoPredFailure)
@@ -60,7 +61,7 @@ import Cardano.Ledger.BaseTypes (
   networkId,
   systemStart,
  )
-import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), Sized (..))
+import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), Sized (..), natVersion)
 import Cardano.Ledger.Binary.Coders
 import Cardano.Ledger.Coin (Coin (..), DeltaCoin, toDeltaCoin)
 import Cardano.Ledger.Rules.ValidationMode (
@@ -231,7 +232,7 @@ disjointRefInputs ::
   Test (BabbageUtxoPredFailure era)
 disjointRefInputs pp inputs refInputs =
   when
-    (pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @BabbageEra)
+    (pvMajor (pp ^. ppProtocolVersionL) == natVersion @10)
     (failureOnNonEmpty common BabbageNonDisjointRefInputs)
   where
     common = inputs `Set.intersection` refInputs

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

@@ -25,6 +25,7 @@ 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
 
@@ -47,3 +48,4 @@ spec = do
   AlonzoImp.spec @era
   describe "BabbageImpSpec" . withImpInit @(LedgerSpec era) $ do
     Utxow.spec
+    Utxo.spec

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

@@ -0,0 +1,65 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Cardano.Ledger.Babbage.Imp.UtxoSpec (spec) where
+
+import Cardano.Ledger.Babbage.Core (
+  BabbageEraTxBody (..),
+  BabbageEraTxOut (..),
+  EraTx (..),
+  EraTxBody (..),
+  EraTxOut (..),
+  KeyRole (..),
+ )
+import Cardano.Ledger.BaseTypes (Inject (..))
+import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
+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,
+  LedgerSpec,
+  submitTx,
+  submitTx_,
+ )
+import Test.Cardano.Ledger.Common (SpecWith, describe, it)
+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
+  describe "Reference scripts" $ do
+    it "Reference inputs can overlap with regular inputs in PlutusV2" $ do
+      let
+        txOut =
+          mkBasicTxOut
+            ( mkAddr
+                (ScriptHashObj @'Payment $ hashPlutusScript (inputsOverlapsWithRefInputs SPlutusV2))
+                StakeRefNull
+            )
+            (inject $ Coin 1_000_000)
+            & datumTxOutL .~ (Datum . dataToBinaryData . Data . PV1.I $ 0)
+      tx <-
+        submitTx $
+          mkBasicTx mkBasicTxBody
+            & bodyTxL . outputsTxBodyL .~ SSeq.singleton txOut
+      let txIn = txInAt (0 :: Integer) tx
+      submitTx_ @era $
+        mkBasicTx mkBasicTxBody
+          & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
+          & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.20.0.0
 
+* Add `ReferenceInputsNotDisjointFromInputs`
 * Bump `ProtVerHigh ConwayEra` to `11`
 * Remove `ConwayTxBody`
 * Removed `era` parameter from `ConwayTxBodyRaw`

eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs

@@ -55,7 +55,7 @@ import Cardano.Ledger.BaseTypes (
   strictMaybe,
   txIxToInt,
  )
-import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
+import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), natVersion)
 import Cardano.Ledger.Binary.Coders (
   Decode (..),
   Encode (..),
@@ -166,6 +166,7 @@ data ConwayContextError era
   | VotingProceduresFieldNotSupported !(VotingProcedures era)
   | ProposalProceduresFieldNotSupported !(OSet.OSet (ProposalProcedure era))
   | TreasuryDonationFieldNotSupported !Coin
+  | ReferenceInputsNotDisjointFromInputs !(Set.Set TxIn)
   deriving (Generic)
 
 deriving instance
@@ -232,6 +233,8 @@ instance
       encode $ Sum ProposalProceduresFieldNotSupported 13 !> To proposalProcedures
     TreasuryDonationFieldNotSupported coin ->
       encode $ Sum TreasuryDonationFieldNotSupported 14 !> To coin
+    ReferenceInputsNotDisjointFromInputs common ->
+      encode $ Sum ReferenceInputsNotDisjointFromInputs 15 !> To common
 
 instance
   ( EraPParams era
@@ -249,6 +252,7 @@ instance
     12 -> SumD VotingProceduresFieldNotSupported <! From
     13 -> SumD ProposalProceduresFieldNotSupported <! From
     14 -> SumD TreasuryDonationFieldNotSupported <! From
+    15 -> SumD ReferenceInputsNotDisjointFromInputs <! From
     n -> Invalid n
 
 instance
@@ -281,6 +285,10 @@ instance
       kindObject
         "TreasuryDonationFieldNotSupported"
         ["treasury_donation" .= toJSON coin]
+    ReferenceInputsNotDisjointFromInputs common ->
+      kindObject
+        "ReferenceInputsNotDisjointFromInputs"
+        ["common" .= toJSON common]
 
 -- | Given a TxOut, translate it for V2 and return (Right transalation).
 -- If the transaction contains any Byron addresses or Babbage features, return Left.
@@ -457,8 +465,15 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
   toPlutusTxInfo proxy LedgerTxInfo {ltiProtVer, ltiEpochInfo, ltiSystemStart, ltiUTxO, ltiTx} = do
     timeRange <-
       Alonzo.transValidityInterval ltiTx ltiProtVer ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
-    inputs <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList (txBody ^. inputsTxBodyL))
-    refInputs <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList (txBody ^. referenceInputsTxBodyL))
+    let
+      txInputs = txBody ^. inputsTxBodyL
+      refInputs = txBody ^. referenceInputsTxBodyL
+    inputsInfo <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList txInputs)
+    refInputsInfo <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList refInputs)
+    let
+      commonInputs = txInputs `Set.intersection` refInputs
+    unless (pvMajor ltiProtVer < natVersion @11 || Set.null commonInputs) . Left $
+      ReferenceInputsNotDisjointFromInputs commonInputs
     outputs <-
       zipWithM
         (Babbage.transTxOutV2 . TxOutFromOutput)
@@ -468,9 +483,9 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
     plutusRedeemers <- Babbage.transTxRedeemers proxy ltiProtVer ltiTx
     pure
       PV3.TxInfo
-        { PV3.txInfoInputs = inputs
+        { PV3.txInfoInputs = inputsInfo
         , PV3.txInfoOutputs = outputs
-        , PV3.txInfoReferenceInputs = refInputs
+        , PV3.txInfoReferenceInputs = refInputsInfo
         , PV3.txInfoFee = transCoinToLovelace (txBody ^. feeTxBodyL)
         , PV3.txInfoMint = transMintValue (txBody ^. mintTxBodyL)
         , PV3.txInfoTxCerts = txCerts

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

@@ -90,6 +90,7 @@ spec ::
   , ToExpr (Event (EraRule "ENACT" era))
   , Eq (Event (EraRule "ENACT" era))
   , Typeable (Event (EraRule "ENACT" era))
+  , ContextError era ~ ConwayContextError era
   ) =>
   Spec
 spec = do
@@ -125,6 +126,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