WIP

Author: Soupstraw

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/conway/impl/cardano-ledger-conway.cabal

@@ -185,6 +185,7 @@ library testlib
     microlens-mtl,
     mtl,
     plutus-ledger-api,
+    plutus-preprocessor,
     prettyprinter,
     small-steps >=1.1,
     text,

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

@@ -160,6 +160,7 @@ data ConwayContextError era
   | VotingProceduresFieldNotSupported !(VotingProcedures era)
   | ProposalProceduresFieldNotSupported !(OSet.OSet (ProposalProcedure era))
   | TreasuryDonationFieldNotSupported !Coin
+  | ReferenceInputsNotDisjointFromInputs !(Set.Set TxIn)
   deriving (Generic)
 
 deriving instance
@@ -226,6 +227,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
@@ -243,6 +246,7 @@ instance
     12 -> SumD VotingProceduresFieldNotSupported <! From
     13 -> SumD ProposalProceduresFieldNotSupported <! From
     14 -> SumD TreasuryDonationFieldNotSupported <! From
+    15 -> SumD ReferenceInputsNotDisjointFromInputs <! From
     n -> Invalid n
 
 instance
@@ -275,6 +279,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.
@@ -451,8 +459,14 @@ 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 (Set.null commonInputs) . Left $ ReferenceInputsNotDisjointFromInputs commonInputs
     outputs <-
       zipWithM
         (Babbage.transTxOutV2 . TxOutFromOutput)
@@ -462,9 +476,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/UtxoSpec.hs

@@ -1,6 +1,8 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -16,8 +18,10 @@ 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.MemoBytes (getMemoRawBytes)
-import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript, plutusBinary)
+import Cardano.Ledger.Plutus.Language (Language (..), Plutus (..), PlutusLanguage, SLanguage (..), hashPlutusScript)
+import Cardano.Ledger.Plutus.Preprocessor.Binary.V2 (inputsIsSubsetOfRefInputsBytes)
 import Cardano.Ledger.Shelley.Core
 import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Scripts (
@@ -39,6 +43,11 @@ 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 Data.Maybe (fromJust)
+import Cardano.Ledger.Conway.Core (AlonzoEraTxWits(..), ppMaxTxExUnitsL, AlonzoEraTxBody (..))
+import Cardano.Ledger.Alonzo.TxWits (Redeemers(..))
+import Cardano.Ledger.Plutus (Data(..))
+import qualified PlutusLedgerApi.Common as P
 
 spec ::
   forall era.
@@ -63,6 +72,37 @@ spec =
         [fromNativeScript spendingScript, fromNativeScript spendingScript]
           ++ extraScripts
           ++ extraScripts
+    describe "disjoint inputs and reference inputs" $ do
+      let
+        plutus = Plutus $ snd inputsIsSubsetOfRefInputsBytes
+        scriptAddr :: forall (pv :: Language). PlutusLanguage pv => Addr
+        scriptAddr =
+          mkAddr
+            (ScriptHashObj @'Payment $ hashPlutusScript @pv plutus)
+            StakeRefNull
+        script :: forall (pv :: Language). PlutusLanguage pv => PlutusScript era
+        script = fromJust $ mkPlutusScript @era @pv plutus
+      --it "Same script can appear in regular and reference inputs in PlutusV2" $ do
+      --  txIn <- sendCoinTo (scriptAddr @'PlutusV2) $ Coin 1_000_000
+      --  submitTx_ $
+      --    mkBasicTx mkBasicTxBody
+      --      & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
+      --      & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
+      --      & witsTxL . scriptTxWitsL .~ Map.singleton (hashPlutusScript @'PlutusV2 plutus) (PlutusScript $ script @'PlutusV2)
+      it "Same script cannot appear in regular and reference inputs in PlutusV3" $ do
+        maxExUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
+        txIn <- sendCoinTo (scriptAddr @'PlutusV3) $ Coin 1_000_000
+        collateralIn <- sendCoinTo (scriptAddr @'PlutusV3) $ Coin 1_000_000_000
+        let
+          tx =
+            mkBasicTx mkBasicTxBody
+              & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
+              & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
+              & bodyTxL . collateralInputsTxBodyL .~ Set.singleton collateralIn
+              & bodyTxL . feeTxBodyL .~ Coin 100_000_000
+              & witsTxL . scriptTxWitsL .~ Map.singleton (hashPlutusScript @'PlutusV3 plutus) (PlutusScript $ script @'PlutusV3)
+              & witsTxL . rdmrsTxWitsL .~ Redeemers (Map.singleton (SpendingPurpose (AsIx 0)) (Data $ P.I 0, maxExUnits))
+        submitTx_ @era tx
   where
     checkMinFee :: HasCallStack => NativeScript era -> [Script era] -> ImpTestM era ()
     checkMinFee scriptToSpend refScripts = do

libs/plutus-preprocessor/src/Cardano/Ledger/Plutus/Preprocessor/Binary/V2.hs

@@ -28,6 +28,7 @@ $purposeIsWellformedWithDatumQ
 $datumIsWellformedQ
 $inputsOutputsAreNotEmptyNoDatumQ
 $inputsOutputsAreNotEmptyWithDatumQ
+$inputsIsSubsetOfRefInputsQ
 
 -- ================================================================
 -- Compile and serialize the real functions as Plutus scripts.
@@ -110,3 +111,9 @@ inputsOutputsAreNotEmptyWithDatumBytes =
   ( inputsOutputsAreNotEmptyWithDatumQ
   , PlutusBinary $ PV2.serialiseCompiledCode $$(P.compile [||inputsOutputsAreNotEmptyWithDatum||])
   )
+
+inputsIsSubsetOfRefInputsBytes :: (Q [Dec], PlutusBinary)
+inputsIsSubsetOfRefInputsBytes =
+  ( inputsIsSubsetOfRefInputsQ
+  , PlutusBinary $ PV2.serialiseCompiledCode $$(P.compile [||inputsIsSubsetOfRefInputs||])
+  )

libs/plutus-preprocessor/src/Cardano/Ledger/Plutus/Preprocessor/Source/V2.hs

@@ -228,3 +228,16 @@ inputsOutputsAreNotEmptyWithDatumQ =
                     then P.error ()
                     else ()
     |]
+
+inputsIsSubsetOfRefInputsQ :: Q [Dec]
+inputsIsSubsetOfRefInputsQ =
+  [d|
+    inputsIsSubsetOfRefInputs :: P.BuiltinData -> P.BuiltinData -> P.BuiltinData -> ()
+    inputsIsSubsetOfRefInputs _datum _redeemer context =
+      case unsafeFromBuiltinData context of
+        PV2D.ScriptContext txInfo _scriptPurpose ->
+          if PLD.all (\x -> P.isJust . PLD.find (P.== x) $ PV2D.txInfoReferenceInputs txInfo) $
+            PV2D.txInfoInputs txInfo
+            then ()
+            else P.error ()
+    |]