Enable Plutus v1 reference scripts in Conway

eras/alonzo/impl/CHANGELOG.md

@@ -28,6 +28,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,
@@ -48,12 +62,12 @@ import Cardano.Ledger.Shelley.LedgerState (
   nesEsL,
   utxosUtxoL,
  )
-import Cardano.Ledger.Shelley.UTxO (EraUTxO (..), txinLookup)
+import Cardano.Ledger.Shelley.UTxO (EraUTxO (..))
 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
@@ -62,6 +76,7 @@ import Lens.Micro.Mtl (use, (%=), (.=))
 import Test.Cardano.Ledger.Allegra.ImpTest (impAllegraSatisfyNativeScript)
 import Test.Cardano.Ledger.Alonzo.TreeDiff ()
 import Test.Cardano.Ledger.Common
+import Test.Cardano.Ledger.Imp.Common (expectJust)
 import Test.Cardano.Ledger.Plutus (PlutusArgs (..), ScriptTestContext (..), testingCostModels)
 import Test.Cardano.Ledger.Shelley.ImpTest as ImpTest
 
@@ -112,6 +127,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 +153,28 @@ 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))
+    Redeemers oldRedeemers = tx ^. witsTxL . rdmrsTxWitsL
+    newRedeemers = Map.fromList $ mkNewRedeemers <$> contexts
+  pure $
+    tx
+      & witsTxL . rdmrsTxWitsL <>~ Redeemers (Map.union oldRedeemers 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 +186,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
+
+fixupDatums ::
+  forall era.
+  ( HasCallStack
+  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
+  , AlonzoEraTxWits era
+  , AlonzoEraUTxO era
+  , AlonzoEraTxOut era
+  , ShelleyEraImp era
+  ) =>
+  Tx era ->
+  ImpTestM era (Tx era)
+fixupDatums tx = do
+  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 (purpose, _, _) = do
+      AsItem txIn <- expectJust . toSpendingPurpose $ hoistPlutusPurpose toAsItem purpose
+      txOut <- impLookupUTxO @era txIn
+      pure $ case txOut ^. datumTxOutF of
+        DatumHash _dh -> spendDatum <$> Map.lookup (txOutScriptHash txOut) scripts
+        _ -> Nothing
+  datums <- traverse filterInline contexts
+  let TxDats prevDats = tx ^. witsTxL . datsTxWitsL
+  pure $
+    tx
       & witsTxL . datsTxWitsL
-        <>~ TxDats
-          (Map.fromList . catMaybes $ txDats ++ inputDats)
+        .~ TxDats
+          (Map.union prevDats $ fromElems hashData (catMaybes datums))
 
 fixupPPHash ::
   forall era.
@@ -203,6 +258,7 @@ alonzoFixupTx ::
   , AlonzoEraTxWits era
   , AlonzoEraTxBody era
   , ScriptsNeeded era ~ AlonzoScriptsNeeded era
+  , AlonzoEraUTxO era
   ) =>
   Tx era ->
   ImpTestM era (Tx era)
@@ -211,6 +267,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 instances for `InjectRuleFailure` and switch to using `injectFailure`
 * Add `NFData` instance for `BabbageUtxoPredFailure`, `BabbageUtxowPredFailure`
 * Add implementation for `getMinFeeTxUtxo`

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

@@ -1,17 +1,38 @@
+{-# 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.UTxO (AlonzoEraUTxO, AlonzoScriptsNeeded)
 import Cardano.Ledger.Babbage (BabbageEra)
+import Cardano.Ledger.Babbage.Core (
+  AlonzoEraTxWits (..),
+  BabbageEraTxBody (..),
+ )
 import Cardano.Ledger.Core
 import Cardano.Ledger.Crypto (Crypto (..))
+import Cardano.Ledger.Shelley.UTxO (EraUTxO (..))
 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,
+  initAlonzoImpNES,
+  updateAddrTxWits,
+ )
 import Test.Cardano.Ledger.Babbage.TreeDiff ()
 import Test.Cardano.Ledger.Common
 import Test.Cardano.Ledger.Shelley.ImpTest (ShelleyEraImp (..))
@@ -26,4 +47,23 @@ instance
   where
   initImpNES = initAlonzoImpNES
   impSatisfyNativeScript = impAllegraSatisfyNativeScript
-  fixupTx = alonzoFixupTx
+  fixupTx = babbageFixupTx
+
+babbageFixupTx ::
+  ( ShelleyEraImp era
+  , AlonzoEraTxWits era
+  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
+  , BabbageEraTxBody era
+  , AlonzoEraUTxO era
+  ) =>
+  Tx era ->
+  ImpTestM era (Tx era)
+babbageFixupTx =
+  addNativeScriptTxWits
+    >=> addCollateralInput
+    >=> addRootTxIn
+    >=> fixupPlutusScripts
+    >=> fixupDatums
+    >=> fixupPPHash
+    >=> fixupFees
+    >=> updateAddrTxWits

eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/TxInfo.hs

@@ -17,7 +17,7 @@ import Cardano.Ledger.Alonzo.Plutus.Context (
 import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (..), TxOutSource (..))
 import Cardano.Ledger.Babbage.Core
 import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..), transTxInInfoV2, transTxOutV2)
-import Cardano.Ledger.BaseTypes (Inject (..), Network (..), StrictMaybe (..))
+import Cardano.Ledger.BaseTypes (Inject (..), Network (..), StrictMaybe (..), natVersion)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Credential (StakeReference (..))
 import Cardano.Ledger.Crypto (Crypto)
@@ -274,39 +274,43 @@ txInfoTestsV1 ::
 txInfoTestsV1 _ =
   testGroup
     "Plutus V1"
-    [ testCase "translation error on byron txout" $
-        expectV1TranslationError @era
-          (txBare shelleyInput byronOutput)
-          (inject $ ByronTxOutInContext @era (TxOutFromOutput minBound))
-    , testCase "translation error on byron txin" $
-        expectV1TranslationError @era
-          (txBare byronInput shelleyOutput)
-          (inject $ ByronTxOutInContext @era (TxOutFromInput byronInput))
-    , testCase "translation error on unknown txin (logic error)" $
-        expectV1TranslationError @era
-          (txBare unknownInput shelleyOutput)
-          (inject $ AlonzoContextError $ TranslationLogicMissingInput @era unknownInput)
-    , testCase "translation error on reference input" $
-        expectV1TranslationError @era
-          (txRefInput shelleyInput)
-          (inject $ ReferenceInputsNotSupported @era (Set.singleton shelleyInput))
-    , testCase "translation error on inline datum in input" $
-        expectV1TranslationError @era
-          (txBare inputWithInlineDatum shelleyOutput)
-          (inject $ InlineDatumsNotSupported @era (TxOutFromInput inputWithInlineDatum))
-    , testCase "translation error on inline datum in output" $
-        expectV1TranslationError @era
-          (txBare shelleyInput inlineDatumOutput)
-          (inject $ InlineDatumsNotSupported @era (TxOutFromOutput minBound))
-    , testCase "translation error on reference script in input" $
-        expectV1TranslationError @era
-          (txBare inputWithRefScript shelleyOutput)
-          (inject $ ReferenceScriptsNotSupported @era (TxOutFromInput inputWithRefScript))
-    , testCase "translation error on reference script in output" $
-        expectV1TranslationError @era
-          (txBare shelleyInput refScriptOutput)
-          (inject $ ReferenceScriptsNotSupported @era (TxOutFromOutput minBound))
-    ]
+    $ [ testCase "translation error on byron txout" $
+          expectV1TranslationError @era
+            (txBare shelleyInput byronOutput)
+            (inject $ ByronTxOutInContext @era (TxOutFromOutput minBound))
+      , testCase "translation error on byron txin" $
+          expectV1TranslationError @era
+            (txBare byronInput shelleyOutput)
+            (inject $ ByronTxOutInContext @era (TxOutFromInput byronInput))
+      , testCase "translation error on unknown txin (logic error)" $
+          expectV1TranslationError @era
+            (txBare unknownInput shelleyOutput)
+            (inject $ AlonzoContextError $ TranslationLogicMissingInput @era unknownInput)
+      , testCase "translation error on inline datum in input" $
+          expectV1TranslationError @era
+            (txBare inputWithInlineDatum shelleyOutput)
+            (inject $ InlineDatumsNotSupported @era (TxOutFromInput inputWithInlineDatum))
+      , testCase "translation error on inline datum in output" $
+          expectV1TranslationError @era
+            (txBare shelleyInput inlineDatumOutput)
+            (inject $ InlineDatumsNotSupported @era (TxOutFromOutput minBound))
+      ]
+      ++ if eraProtVerLow @era < natVersion @9
+        then
+          [ testCase "translation error on reference script in input" $
+              expectV1TranslationError @era
+                (txBare inputWithRefScript shelleyOutput)
+                (inject $ ReferenceScriptsNotSupported @era (TxOutFromInput inputWithRefScript))
+          , testCase "translation error on reference script in output" $
+              expectV1TranslationError @era
+                (txBare shelleyInput refScriptOutput)
+                (inject $ ReferenceScriptsNotSupported @era (TxOutFromOutput minBound))
+          , testCase "translation error on reference input" $
+              expectV1TranslationError @era
+                (txRefInput shelleyInput)
+                (inject $ ReferenceInputsNotSupported @era (Set.singleton shelleyInput))
+          ]
+        else []
 
 txInfoTestsV2 ::
   forall era l.