Removed PlutusV1 reference inputs check

eras/alonzo/impl/CHANGELOG.md

@@ -26,6 +26,13 @@
 
 ### `testlib`
 
+* Add:
+  * `impLookupPlutusScript`
+  * `fixupPPHash`
+  * `fixupPlutusScripts`
+  * `addCollateralInput`
+  * `impGetPlutusContexts`
+  * `fixupDatums`
 * Add `Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec`
 * Add `alonzoFixupTx`, `impAddPlutusScript`
 

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

@@ -14,30 +14,44 @@ module Test.Cardano.Ledger.Alonzo.ImpTest (
   initAlonzoImpNES,
   PlutusArgs (..),
   impAddPlutusScript,
+  impLookupPlutusScript,
+  fixupPPHash,
+  fixupPlutusScripts,
+  addCollateralInput,
   alonzoFixupTx,
+  impGetPlutusContexts,
+  fixupDatums,
 ) where
 
 import Cardano.Crypto.DSIGN.Class (DSIGNAlgorithm (..))
 import Cardano.Crypto.Hash (Hash)
+import Cardano.Ledger.Address (Addr (..))
 import Cardano.Ledger.Alonzo (AlonzoEra)
-import Cardano.Ledger.Alonzo.Core (AlonzoEraScript (..), AlonzoEraTxOut (..), Era (..), EraGov)
+import Cardano.Ledger.Alonzo.Core (AlonzoEraScript (..), AlonzoEraTxOut (..), AsIxItem, Era (..), EraGov)
 import Cardano.Ledger.Alonzo.PParams (AlonzoEraPParams, getLanguageView, ppCostModelsL, ppMaxTxExUnitsL, ppMaxValSizeL)
-import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), plutusScriptLanguage, toAsIx)
+import Cardano.Ledger.Alonzo.Scripts (
+  AsItem (..),
+  ExUnits (..),
+  plutusScriptLanguage,
+  toAsItem,
+  toAsIx,
+ )
 import Cardano.Ledger.Alonzo.Tx (hashScriptIntegrity)
 import Cardano.Ledger.Alonzo.TxBody (AlonzoEraTxBody (..))
 import Cardano.Ledger.Alonzo.TxWits (AlonzoEraTxWits (..), Redeemers (..), TxDats (..))
-import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded (..))
+import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO (..), AlonzoScriptsNeeded (..))
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core (
   EraIndependentTxBody,
   EraScript (..),
   EraTx (..),
-  EraTxBody (..),
+  EraTxOut (..),
   EraTxWits (..),
   ScriptHash,
  )
+import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Crypto (Crypto (..))
-import Cardano.Ledger.Plutus.Data (Data (..), Datum (..), binaryDataToData, hashData)
+import Cardano.Ledger.Plutus.Data (Data (..), Datum (..), hashData)
 import Cardano.Ledger.Plutus.Language (Language (..), Plutus, PlutusLanguage, hashPlutusScript)
 import Cardano.Ledger.Shelley.LedgerState (
   NewEpochState,
@@ -52,8 +66,8 @@ import Cardano.Ledger.Shelley.UTxO (EraUTxO (..), txinLookup)
 import Cardano.Ledger.TxIn (TxIn)
 import Control.Monad (forM)
 import Data.Default.Class (Default)
-import Data.Foldable (Foldable (..))
 import qualified Data.Map.Strict as Map
+import Data.MapExtras (fromElems)
 import Data.Maybe (catMaybes)
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -112,6 +126,21 @@ impLookupPlutusScript sh = do
     Just (ScriptTestContext plutus _) -> pure $ mkPlutusScript plutus
     Nothing -> pure Nothing
 
+impGetPlutusContexts ::
+  (ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era) =>
+  Tx era ->
+  ImpTestM
+    era
+    [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era), ScriptTestContext)]
+impGetPlutusContexts tx = do
+  let txBody = tx ^. bodyTxL
+  utxo <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosUtxoL
+  let AlonzoScriptsNeeded asn = getScriptsNeeded utxo txBody
+  mbyContexts <- forM asn $ \(prp, sh) -> do
+    ctx <- getScriptTestContext sh
+    pure $ (prp,sh,) <$> ctx
+  pure $ catMaybes mbyContexts
+
 fixupPlutusScripts ::
   forall era.
   ( EraUTxO era
@@ -123,15 +152,27 @@ fixupPlutusScripts ::
   Tx era ->
   ImpTestM era (Tx era)
 fixupPlutusScripts tx = do
-  utxo <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosUtxoL
+  contexts <- impGetPlutusContexts tx
+  exUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
   let
-    txBody = tx ^. bodyTxL
-    AlonzoScriptsNeeded asn = getScriptsNeeded utxo txBody
-  mbyContexts <- forM asn $ \(prp, sh) -> do
-    ctx <- getScriptTestContext sh
-    pure $ (prp,sh,) <$> ctx
+    mkNewRedeemers (prpIdx, _, ScriptTestContext _ (PlutusArgs dat _)) =
+      (hoistPlutusPurpose @era toAsIx prpIdx, (Data dat, exUnits))
+    newRedeemers = Redeemers . Map.fromList $ mkNewRedeemers <$> contexts
+  pure $
+    tx
+      & witsTxL . rdmrsTxWitsL <>~ newRedeemers
+
+fixupScriptWits ::
+  forall era.
+  ( ScriptsNeeded era ~ AlonzoScriptsNeeded era
+  , AlonzoEraScript era
+  , EraUTxO era
+  ) =>
+  Tx era ->
+  ImpTestM era (Tx era)
+fixupScriptWits tx = do
+  contexts <- impGetPlutusContexts tx
   let
-    contexts = catMaybes mbyContexts
     plutusToScript ::
       forall l.
       PlutusLanguage l =>
@@ -143,31 +184,43 @@ fixupPlutusScripts tx = do
         Nothing -> error "Plutus version not supported by era"
   scriptWits <- forM contexts $ \(_, sh, ScriptTestContext plutus _) ->
     (sh,) <$> plutusToScript plutus
-  exUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
-  let
-    mkNewRedeemers (prpIdx, _, ScriptTestContext _ (PlutusArgs dat _)) =
-      (hoistPlutusPurpose @era toAsIx prpIdx, (Data dat, exUnits))
-    newRedeemers = Redeemers . Map.fromList $ mkNewRedeemers <$> contexts
-    mkTxDats (_, _, ScriptTestContext _ (PlutusArgs _ datum)) =
-      (\d -> (hashData d, d)) . Data <$> datum
-    txDats = mkTxDats <$> contexts
-    mkInputDats txIn =
-      case txinLookup txIn utxo of
-        Just txOut ->
-          case txOut ^. datumTxOutF of
-            Datum bin -> do
-              let dat = binaryDataToData bin
-              Just (hashData dat, dat)
-            _ -> Nothing
-        Nothing -> error $ "TxIn not found in the UTxO: " <> show txIn
-    inputDats = mkInputDats <$> toList (txBody ^. inputsTxBodyL)
   pure $
     tx
       & witsTxL . scriptTxWitsL <>~ Map.fromList scriptWits
-      & witsTxL . rdmrsTxWitsL <>~ newRedeemers
-      & witsTxL . datsTxWitsL
-        <>~ TxDats
-          (Map.fromList . catMaybes $ txDats ++ inputDats)
+
+fixupDatums ::
+  forall era.
+  ( ScriptsNeeded era ~ AlonzoScriptsNeeded era
+  , AlonzoEraTxWits era
+  , AlonzoEraUTxO era
+  , AlonzoEraTxOut era
+  ) =>
+  Tx era ->
+  ImpTestM era (Tx era)
+fixupDatums tx = do
+  utxo <- getUTxO
+  contexts <- impGetPlutusContexts tx
+  scripts <- use impScriptsL
+  let
+    txOutScriptHash txOut
+      | Addr _ (ScriptHashObj sh) _ <- txOut ^. addrTxOutL = sh
+      | otherwise = error "TxOut does not have a payment script"
+    spendDatum (ScriptTestContext _ (PlutusArgs _ (Just d))) = Data d
+    spendDatum _ = error "Context does not have a spending datum"
+    filterInline (prps, _, _) = do
+      AsItem txIn <- toSpendingPurpose $ hoistPlutusPurpose toAsItem prps
+      let
+        txOut =
+          case txinLookup txIn utxo of
+            Just x -> x
+            Nothing -> error "Could not find TxOut"
+      case txOut ^. datumTxOutF of
+        DatumHash _dh -> spendDatum <$> Map.lookup (txOutScriptHash txOut) scripts
+        _ -> Nothing
+    datums = filterInline <$> contexts
+  pure $
+    tx
+      & witsTxL . datsTxWitsL .~ TxDats (fromElems hashData $ catMaybes datums)
 
 fixupPPHash ::
   forall era.
@@ -203,6 +256,7 @@ alonzoFixupTx ::
   , AlonzoEraTxWits era
   , AlonzoEraTxBody era
   , ScriptsNeeded era ~ AlonzoScriptsNeeded era
+  , AlonzoEraUTxO era
   ) =>
   Tx era ->
   ImpTestM era (Tx era)
@@ -211,6 +265,8 @@ alonzoFixupTx =
     >=> addCollateralInput
     >=> addRootTxIn
     >=> fixupPlutusScripts
+    >=> fixupScriptWits
+    >=> fixupDatums
     >=> fixupPPHash
     >=> fixupFees
     >=> updateAddrTxWits

eras/babbage/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.7.0.0
 
+* Add `babbageFixupTx`
 * Add `NFData` instance for `BabbageUtxoPredFailure`, `BabbageUtxowPredFailure`
 * Add implementation for `getMinFeeTxUtxo`
 * Add `getReferenceScriptsNonDistinct`

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

@@ -101,7 +101,9 @@ library testlib
 
     build-depends:
         base,
+        microlens,
         bytestring,
+        containers,
         cardano-ledger-allegra:testlib,
         cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib},
         cardano-ledger-shelley:{cardano-ledger-shelley, testlib},

eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs

@@ -17,7 +17,7 @@
 module Cardano.Ledger.Babbage.TxInfo (
   BabbageContextError (..),
   transReferenceScript,
-  transTxOutV1,
+  babbageTransTxOutV1,
   transTxOutV2,
   transTxInInfoV1,
   transTxInInfoV2,
@@ -88,7 +88,7 @@ transReferenceScript (SJust s) = Just . transScriptHash . hashScript @era $ s
 
 -- | Given a TxOut, translate it for V2 and return (Right transalation).
 -- If the transaction contains any Byron addresses or Babbage features, return Left.
-transTxOutV1 ::
+babbageTransTxOutV1 ::
   forall era.
   ( Inject (BabbageContextError era) (ContextError era)
   , Value era ~ MaryValue (EraCrypto era)
@@ -97,7 +97,7 @@ transTxOutV1 ::
   TxOutSource (EraCrypto era) ->
   TxOut era ->
   Either (ContextError era) PV1.TxOut
-transTxOutV1 txOutSource txOut = do
+babbageTransTxOutV1 txOutSource txOut = do
   when (isSJust (txOut ^. referenceScriptTxOutL)) $ do
     Left $ inject $ ReferenceScriptsNotSupported @era txOutSource
   when (isSJust (txOut ^. dataTxOutL)) $ do
@@ -148,7 +148,7 @@ transTxInInfoV1 ::
   Either (ContextError era) PV1.TxInInfo
 transTxInInfoV1 utxo txIn = do
   txOut <- left (inject . AlonzoContextError @era) $ Alonzo.transLookupTxOut utxo txIn
-  plutusTxOut <- transTxOutV1 (TxOutFromInput txIn) txOut
+  plutusTxOut <- babbageTransTxOutV1 (TxOutFromInput txIn) txOut
   Right (PV1.TxInInfo (transTxIn txIn) plutusTxOut)
 
 -- | Given a TxIn, look it up in the UTxO. If it exists, translate it to the V2 context
@@ -294,7 +294,7 @@ instance Crypto c => EraPlutusTxInfo 'PlutusV1 (BabbageEra c) where
     inputs <- mapM (transTxInInfoV1 utxo) (Set.toList (txBody ^. inputsTxBodyL))
     outputs <-
       zipWithM
-        (transTxOutV1 . TxOutFromOutput)
+        (babbageTransTxOutV1 . TxOutFromOutput)
         [minBound ..]
         (F.toList (txBody ^. outputsTxBodyL))
     txCerts <- Alonzo.transTxBodyCerts proxy txBody

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

@@ -1,17 +1,45 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Test.Cardano.Ledger.Babbage.ImpTest () where
+module Test.Cardano.Ledger.Babbage.ImpTest (babbageFixupTx) where
 
 import Cardano.Crypto.DSIGN.Class (DSIGNAlgorithm (..))
 import Cardano.Crypto.Hash (Hash)
+import Cardano.Ledger.Alonzo.Scripts (isPlutusScript)
+import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO, AlonzoScriptsNeeded)
 import Cardano.Ledger.Babbage (BabbageEra)
+import Cardano.Ledger.Babbage.Core (
+  AlonzoEraTxWits (..),
+  BabbageEraTxBody (..),
+  BabbageEraTxOut (..),
+ )
+import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import Cardano.Ledger.Core
 import Cardano.Ledger.Crypto (Crypto (..))
+import Cardano.Ledger.Shelley.UTxO (EraUTxO (..), txinLookup)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import Lens.Micro ((%~), (&), (^.))
 import Test.Cardano.Ledger.Allegra.ImpTest (impAllegraSatisfyNativeScript)
-import Test.Cardano.Ledger.Alonzo.ImpTest (alonzoFixupTx, initAlonzoImpNES)
+import Test.Cardano.Ledger.Alonzo.ImpTest (
+  ImpTestM,
+  addCollateralInput,
+  addNativeScriptTxWits,
+  addRootTxIn,
+  fixupDatums,
+  fixupFees,
+  fixupPPHash,
+  fixupPlutusScripts,
+  getUTxO,
+  initAlonzoImpNES,
+  updateAddrTxWits,
+ )
 import Test.Cardano.Ledger.Babbage.TreeDiff ()
 import Test.Cardano.Ledger.Common
 import Test.Cardano.Ledger.Shelley.ImpTest (ShelleyEraImp (..))
@@ -26,4 +54,48 @@ instance
   where
   initImpNES = initAlonzoImpNES
   impSatisfyNativeScript = impAllegraSatisfyNativeScript
-  fixupTx = alonzoFixupTx
+  fixupTx = babbageFixupTx
+
+babbageFixupScriptWits ::
+  forall era.
+  ( EraUTxO era
+  , BabbageEraTxBody era
+  ) =>
+  Tx era ->
+  ImpTestM era (Tx era)
+babbageFixupScriptWits tx = do
+  utxo <- getUTxO
+  let
+    refInputs = tx ^. bodyTxL . referenceInputsTxBodyL
+    lookupAddPlutusRefScripts txIn =
+      case txinLookup txIn utxo of
+        Just txOut ->
+          case txOut ^. referenceScriptTxOutL of
+            SJust script | isPlutusScript script -> Set.insert $ hashScript script
+            _ -> id
+        Nothing -> error $ "TxIn not found in UTxO: " <> show txIn
+  let
+    plutusRefScripts = Set.foldr' lookupAddPlutusRefScripts mempty refInputs
+  pure $
+    tx
+      & witsTxL . scriptTxWitsL %~ (`Map.withoutKeys` plutusRefScripts)
+
+babbageFixupTx ::
+  ( ShelleyEraImp era
+  , AlonzoEraTxWits era
+  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
+  , BabbageEraTxBody era
+  , AlonzoEraUTxO era
+  ) =>
+  Tx era ->
+  ImpTestM era (Tx era)
+babbageFixupTx =
+  addNativeScriptTxWits
+    >=> addCollateralInput
+    >=> addRootTxIn
+    >=> fixupPlutusScripts
+    >=> babbageFixupScriptWits
+    >=> fixupDatums
+    >=> fixupPPHash
+    >=> fixupFees
+    >=> updateAddrTxWits