Disabled BabbageNonDisjointRefInputs predicate failure for PlutusV2 scripts

Add majorVersionAtLeast and majorVersionAtMost

Co-authored-by: Alexey Kuleshevich <[email protected]>

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 | hashData @era (spendDatum x) == dh -> pure . Just $ spendDatum x
+              _ -> 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
@@ -302,10 +315,10 @@ fixupPPHash tx = impAnn "fixupPPHash" $ do
   let
     scriptHashes :: Set ScriptHash
     scriptHashes = getScriptsHashesNeeded . getScriptsNeeded utxo $ tx ^. bodyTxL
-    plutusLanguage sh = do
+    scriptLanguage sh = do
       let mbyPlutus = impLookupPlutusScript sh
       pure $ getLanguageView pp . plutusScriptLanguage @era <$> mbyPlutus
-  langs <- traverse plutusLanguage $ Set.toList scriptHashes
+  langs <- traverse scriptLanguage $ Set.toList scriptHashes
   let
     integrityHash =
       hashScriptIntegrity
@@ -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
 * Added `ppCoinsPerUTxOByte` to `PParams`
 * Removed `babbagePParamsHKDPairs` and `babbageCommonPParamsHKDPairs` from `PParams`
 * Remove `BabbageTxBody`

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,9 @@ disjointRefInputs ::
   Test (BabbageUtxoPredFailure era)
 disjointRefInputs pp inputs refInputs =
   when
-    (pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @BabbageEra)
+    ( pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @BabbageEra
+        && pvMajor (pp ^. ppProtocolVersionL) < natVersion @11
+    )
     (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,68 @@
+{-# 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 (..),
+  ppProtocolVersionL,
+ )
+import Cardano.Ledger.BaseTypes (Inject (..), ProtVer (..), natVersion)
+import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.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,
+  getsPParams,
+  submitTx,
+  submitTx_,
+ )
+import Test.Cardano.Ledger.Common (SpecWith, describe, it, when)
+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
+                (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
+      majorVer <- pvMajor <$> getsPParams ppProtocolVersionL
+      when (majorVer < natVersion @9 || majorVer > natVersion @10) $
+        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`
 - Remove `ConwayNewEpochPredFailure` and replace it with `Void`. #5007
 * Added to `PParams`: `ppCommitteeMaxTermLength`,`ppCommitteeMinSize`,`ppDRepActivity`,`ppDRepDeposit`,`ppDRepVotingThresholds`,`ppGovActionDeposit`,`ppGovActionLifetime`,`ppGovProtocolVersion`,`ppMinFeeRefScriptCostPerByte`,`ppPoolVotingThresholds`
 * Moved `ConwayEraPlutusTxInfo` class from `Context` module to `TxInfo`

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

@@ -57,7 +57,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 (..),
@@ -114,6 +114,7 @@ import Control.DeepSeq (NFData)
 import Control.Monad (unless, when, zipWithM)
 import Data.Aeson (ToJSON (..), (.=))
 import Data.Foldable as F (Foldable (..))
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as Map
 import qualified Data.OSet.Strict as OSet
 import qualified Data.Set as Set
@@ -162,6 +163,7 @@ data ConwayContextError era
   | VotingProceduresFieldNotSupported !(VotingProcedures era)
   | ProposalProceduresFieldNotSupported !(OSet.OSet (ProposalProcedure era))
   | TreasuryDonationFieldNotSupported !Coin
+  | ReferenceInputsNotDisjointFromInputs !(NonEmpty TxIn)
   deriving (Generic)
 
 deriving instance
@@ -228,6 +230,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
@@ -245,6 +249,7 @@ instance
     12 -> SumD VotingProceduresFieldNotSupported <! From
     13 -> SumD ProposalProceduresFieldNotSupported <! From
     14 -> SumD TreasuryDonationFieldNotSupported <! From
+    15 -> SumD ReferenceInputsNotDisjointFromInputs <! From
     n -> Invalid n
 
 instance
@@ -277,6 +282,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.
@@ -453,8 +462,16 @@ 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) $ case toList commonInputs of
+      (x : xs) -> Left $ ReferenceInputsNotDisjointFromInputs $ x :| xs
+      _ -> Right ()
     outputs <-
       zipWithM
         (Babbage.transTxOutV2 . TxOutFromOutput)
@@ -464,9 +481,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/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

@@ -1,6 +1,8 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -10,14 +12,23 @@
 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.Conway.TxInfo (ConwayContextError (..))
 import Cardano.Ledger.MemoBytes (getMemoRawBytes)
-import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript, plutusBinary)
+import Cardano.Ledger.Plutus.Language (
+  Plutus (..),
+  SLanguage (..),
+  hashPlutusScript,
+ )
 import Cardano.Ledger.Shelley.Core
 import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Scripts (
@@ -38,11 +49,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)
+import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, inputsOverlapsWithRefInputs)
 
 spec ::
   forall era.
-  ConwayEraImp era =>
+  ( ConwayEraImp era
+  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
+  , Inject (ConwayContextError era) (ContextError era)
+  ) =>
   SpecWith (ImpInit (LedgerSpec era))
 spec =
   describe "Reference scripts" $ do
@@ -63,6 +78,29 @@ spec =
         [fromNativeScript spendingScript, fromNativeScript spendingScript]
           ++ extraScripts
           ++ extraScripts
+    describe "disjoint inputs and reference inputs" $ do
+      let
+        scriptHash lang = hashPlutusScript $ inputsOverlapsWithRefInputs lang
+        mkTestTx :: TxIn -> Tx era
+        mkTestTx txIn =
+          mkBasicTx mkBasicTxBody
+            & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
+            & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
+
+      it "Cannot run scripts that expect inputs and refInputs to overlap (PV 9/10)" $ do
+        whenMajorVersionAtMost @10 $ do
+          txIn <- produceScript $ scriptHash SPlutusV3
+          submitFailingTx @era
+            (mkTestTx txIn)
+            [ injectFailure $ BabbageNonDisjointRefInputs [txIn]
+            ]
+      it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 11)" $ whenMajorVersionAtLeast @11 $ do
+        txIn <- produceScript $ scriptHash SPlutusV3
+        submitFailingTx @era
+          (mkTestTx txIn)
+          [ injectFailure $
+              CollectErrors [BadTranslation . inject $ ReferenceInputsNotDisjointFromInputs @era [txIn]]
+          ]
   where
     checkMinFee :: HasCallStack => NativeScript era -> [Script era] -> ImpTestM era ()
     checkMinFee scriptToSpend refScripts = do