Reference inputs improvements

CHANGELOG.md

@@ -133,6 +133,8 @@
   estimated by cardano-api while it is in fact found in the skeleton itself.
 - A bug where the execution units of the scripts were not computed and fed to
   the transaction body.
+- An imprecision where reference inputs in redeemers that also appear in inputs
+  would be kept in the reference inputs list during generation.
 
 ## [[6.0.0]](https://github.com/tweag/cooked-validators/releases/tag/v6.0.0) - 2025-05-15
 

cabal.project

@@ -24,7 +24,7 @@ repository cardano-haskell-packages
 
 index-state:
   , hackage.haskell.org 2025-04-16T16:04:13Z
-  , cardano-haskell-packages 2025-04-25T15:50:18Z
+  , cardano-haskell-packages 2025-05-16T15:25:35Z
 
 -- We never, ever, want this.
 write-ghc-environment-files: never
@@ -47,12 +47,12 @@ package cardano-crypto-praos
   flags: -external-libsodium-vrf
 
 constraints:
-  cardano-api ^>= 10.15
+  cardano-api == 10.16.1.0
 
 source-repository-package
     type: git
-    location: https://github.com/tweag/cardano-node-emulator-forked
-    tag: 93de6dc68244eed1eb439fb0c7753e8b513b7aa4
+    location: https://github.com/intersectMBO/cardano-node-emulator
+    tag: 6d65996418d2b00fa791407ec47e2fe77c208790
     subdir:
       plutus-script-utils
       plutus-ledger

cooked-validators.cabal

@@ -1,6 +1,6 @@
 cabal-version: 3.4
 
--- This file has been generated from package.yaml by hpack version 0.36.1.
+-- This file has been generated from package.yaml by hpack version 0.37.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -33,6 +33,7 @@ library
       Cooked.MockChain.GenerateTx.Mint
       Cooked.MockChain.GenerateTx.Output
       Cooked.MockChain.GenerateTx.Proposal
+      Cooked.MockChain.GenerateTx.ReferenceInputs
       Cooked.MockChain.GenerateTx.Withdrawals
       Cooked.MockChain.GenerateTx.Witness
       Cooked.MockChain.MinAda

src/Cooked/MockChain/AutoReferenceScripts.hs

@@ -7,49 +7,54 @@ import Control.Monad
 import Cooked.MockChain.BlockChain
 import Cooked.MockChain.UtxoSearch
 import Cooked.Skeleton
+import Data.List (find)
 import Data.Map qualified as Map
-import Data.Maybe
 import Optics.Core
 import Plutus.Script.Utils.Scripts qualified as Script
 import PlutusLedgerApi.V3 qualified as Api
 
--- | Searches through the known utxos for a utxo containing a reference script
--- with a given script hash, and returns the first such utxo found, if any.
-retrieveReferenceScript :: (MonadBlockChain m, Script.ToScriptHash s) => s -> m (Maybe Api.TxOutRef)
-retrieveReferenceScript = (listToMaybe . (fst <$>) <$>) . runUtxoSearch . referenceScriptOutputsSearch
-
 -- | Attempts to find in the index a utxo containing a reference script with the
 -- given script hash, and attaches it to a redeemer when it does not yet have a
 -- reference input and when it is allowed, in which case an event is logged.
-updateRedeemer :: (MonadBlockChain m, Script.ToScriptHash s) => s -> TxSkelRedeemer -> m TxSkelRedeemer
-updateRedeemer script txSkelRed@(TxSkelRedeemer _ Nothing True) = do
-  oRefM <- retrieveReferenceScript script
-  case oRefM of
-    Nothing -> return txSkelRed
-    Just oRef -> do
-      logEvent $ MCLogAddedReferenceScript txSkelRed oRef (Script.toScriptHash script)
-      return $ txSkelRed `withReferenceInput` oRef
-updateRedeemer _ redeemer = return redeemer
+updateRedeemer :: (MonadBlockChain m, Script.ToScriptHash s) => s -> [Api.TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer
+updateRedeemer script inputs txSkelRed@(TxSkelRedeemer _ Nothing True) = do
+  oRefsInInputs <- runUtxoSearch (referenceScriptOutputsSearch script)
+  maybe
+    -- We leave the redeemer unchanged if no reference input was found
+    (return txSkelRed)
+    -- If a reference input is found, we assign it and log the event
+    ( \oRef -> do
+        logEvent $ MCLogAddedReferenceScript txSkelRed oRef (Script.toScriptHash script)
+        return $ txSkelRed `withReferenceInput` oRef
+    )
+    $ case oRefsInInputs of
+      [] -> Nothing
+      -- If possible, we use a reference input appearing in regular inputs
+      l | Just (oRefM', _) <- find (\(r, _) -> r `elem` inputs) l -> Just oRefM'
+      -- If none exist, we use the first one we find elsewhere
+      ((oRefM', _) : _) -> Just oRefM'
+updateRedeemer _ _ redeemer = return redeemer
 
 -- | Goes through the various parts of the skeleton where a redeemer can appear,
 -- and attempts to attach a reference input to each of them, whenever it is
 -- allowed and one has not already been set.
 toTxSkelWithReferenceScripts :: (MonadBlockChain m) => TxSkel -> m TxSkel
-toTxSkelWithReferenceScripts txSkel = do
-  newMints <- forM (txSkelMintsToList $ txSkel ^. txSkelMintsL) $ \(Mint mPol red tks) ->
-    (\x -> Mint mPol x tks) <$> updateRedeemer (Script.toVersioned @Script.MintingPolicy mPol) red
-  newInputs <- forM (Map.toList $ txSkel ^. txSkelInsL) $ \(oRef, red) -> do
+toTxSkelWithReferenceScripts txSkel@TxSkel {..} = do
+  let inputs = Map.keys txSkelIns
+  newMints <- forM (txSkelMintsToList txSkelMints) $ \(Mint mPol red tks) ->
+    (\x -> Mint mPol x tks) <$> updateRedeemer (Script.toVersioned @Script.MintingPolicy mPol) inputs red
+  newInputs <- forM (Map.toList txSkelIns) $ \(oRef, red) -> do
     validatorM <- txSkelOutValidator <$> unsafeTxOutByRef oRef
     case validatorM of
       Nothing -> return (oRef, red)
-      Just scriptHash -> (oRef,) <$> updateRedeemer scriptHash red
-  newProposals <- forM (txSkel ^. txSkelProposalsL) $ \prop ->
+      Just scriptHash -> (oRef,) <$> updateRedeemer scriptHash inputs red
+  newProposals <- forM txSkelProposals $ \prop ->
     case prop ^. txSkelProposalWitnessL of
       Nothing -> return prop
-      Just (script, red) -> flip (set txSkelProposalWitnessL) prop . Just . (script,) <$> updateRedeemer script red
-  newWithdrawals <- forM (Map.toList $ txSkel ^. txSkelWithdrawalsL) $ \(wit, (red, quantity)) -> case wit of
+      Just (script, red) -> flip (set txSkelProposalWitnessL) prop . Just . (script,) <$> updateRedeemer script inputs red
+  newWithdrawals <- forM (Map.toList txSkelWithdrawals) $ \(wit, (red, quantity)) -> case wit of
     Right _ -> return (wit, (red, quantity))
-    Left script -> (Left script,) . (,quantity) <$> updateRedeemer script red
+    Left script -> (Left script,) . (,quantity) <$> updateRedeemer script inputs red
   return $
     txSkel
       & txSkelMintsL

src/Cooked/MockChain/GenerateTx/Body.hs

@@ -10,36 +10,29 @@ where
 
 import Cardano.Api qualified as Cardano
 import Cardano.Api.Internal.Fees qualified as Cardano
-import Cardano.Api.Internal.ProtocolParameters qualified as Cardano
 import Cardano.Api.Internal.Script qualified as Cardano
 import Cardano.Api.Internal.Tx.Body qualified as Cardano
 import Cardano.Api.Ledger qualified as Cardano
-import Cardano.Ledger.Alonzo.Tx qualified as Alonzo
-import Cardano.Ledger.Alonzo.TxBody qualified as Alonzo
-import Cardano.Ledger.Alonzo.TxWits qualified as Alonzo
-import Cardano.Ledger.Conway.PParams qualified as Conway
-import Cardano.Ledger.Plutus qualified as Cardano
 import Cardano.Node.Emulator.Internal.Node qualified as Emulator
-import Control.Lens qualified as Lens
 import Control.Monad
 import Control.Monad.Except
 import Cooked.MockChain.BlockChain
-import Cooked.MockChain.GenerateTx.Collateral qualified as Collateral
+import Cooked.MockChain.GenerateTx.Collateral
 import Cooked.MockChain.GenerateTx.Common
-import Cooked.MockChain.GenerateTx.Input qualified as Input
-import Cooked.MockChain.GenerateTx.Mint qualified as Mint
-import Cooked.MockChain.GenerateTx.Output qualified as Output
-import Cooked.MockChain.GenerateTx.Proposal qualified as Proposal
-import Cooked.MockChain.GenerateTx.Withdrawals qualified as Withdrawals
-import Cooked.MockChain.GenerateTx.Witness qualified as Witness
+import Cooked.MockChain.GenerateTx.Input
+import Cooked.MockChain.GenerateTx.Mint
+import Cooked.MockChain.GenerateTx.Output
+import Cooked.MockChain.GenerateTx.Proposal
+import Cooked.MockChain.GenerateTx.ReferenceInputs
+import Cooked.MockChain.GenerateTx.Withdrawals
+import Cooked.MockChain.GenerateTx.Witness
 import Cooked.Skeleton
 import Cooked.Wallet
 import Data.Map qualified as Map
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Ledger.Address qualified as Ledger
 import Ledger.Tx.CardanoAPI qualified as Ledger
-import Optics.Core
 import Plutus.Script.Utils.Address qualified as Script
 import PlutusLedgerApi.V3 qualified as Api
 
@@ -54,23 +47,16 @@ txSkelToTxBodyContent ::
   Maybe (Set Api.TxOutRef, Wallet) ->
   -- | Returns a Cardano body content
   m (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra)
-txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals | txSkelReferenceInputs <- txSkelReferenceTxOutRefs skel = do
-  txIns <- mapM Input.toTxInAndWitness $ Map.toList txSkelIns
-  txInsReference <-
-    if null txSkelReferenceInputs
-      then return Cardano.TxInsReferenceNone
-      else
-        throwOnToCardanoErrorOrApply
-          "txSkelToBodyContent: Unable to translate reference inputs."
-          (Cardano.TxInsReference Cardano.BabbageEraOnwardsConway)
-          $ mapM Ledger.toCardanoTxIn txSkelReferenceInputs
-  (txInsCollateral, txTotalCollateral, txReturnCollateral) <- Collateral.toCollateralTriplet fee mCollaterals
-  txOuts <- mapM Output.toCardanoTxOut txSkelOuts
+txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do
+  txIns <- mapM toTxInAndWitness $ Map.toList txSkelIns
+  txInsReference <- toInsReference skel
+  (txInsCollateral, txTotalCollateral, txReturnCollateral) <- toCollateralTriplet fee mCollaterals
+  txOuts <- mapM toCardanoTxOut txSkelOuts
   (txValidityLowerBound, txValidityUpperBound) <-
     throwOnToCardanoError
       "txSkelToBodyContent: Unable to translate transaction validity range."
       $ Ledger.toCardanoValidityRange txSkelValidityRange
-  txMintValue <- Mint.toMintValue txSkelMints
+  txMintValue <- toMintValue txSkelMints
   txExtraKeyWits <-
     if null txSkelSigners
       then return Cardano.TxExtraKeyWitnessesNone
@@ -80,12 +66,12 @@ txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals | txSkelReferenceInputs
           (Cardano.TxExtraKeyWitnesses Cardano.AlonzoEraOnwardsConway)
           $ mapM (Ledger.toCardanoPaymentKeyHash . Ledger.PaymentPubKeyHash . Script.toPubKeyHash) txSkelSigners
   txProtocolParams <- Cardano.BuildTxWith . Just . Emulator.ledgerProtocolParameters <$> getParams
-  let txFee = Cardano.TxFeeExplicit Cardano.ShelleyBasedEraConway $ Cardano.Coin fee
   txProposalProcedures <-
     Just . Cardano.Featured Cardano.ConwayEraOnwardsConway
-      <$> Proposal.toProposalProcedures txSkelProposals (txOptAnchorResolution txSkelOpts)
-  txWithdrawals <- Withdrawals.toWithdrawals txSkelWithdrawals
-  let txMetadata = Cardano.TxMetadataNone
+      <$> toProposalProcedures txSkelProposals (txOptAnchorResolution txSkelOpts)
+  txWithdrawals <- toWithdrawals txSkelWithdrawals
+  let txFee = Cardano.TxFeeExplicit Cardano.ShelleyBasedEraConway $ Cardano.Coin fee
+      txMetadata = Cardano.TxMetadataNone
       txAuxScripts = Cardano.TxAuxScriptsNone
       txUpdateProposal = Cardano.TxUpdateProposalNone
       txCertificates = Cardano.TxCertificatesNone
@@ -96,56 +82,14 @@ txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals | txSkelReferenceInputs
   return Cardano.TxBodyContent {..}
 
 -- | Generates a transaction body from a body content
-txBodyContentToTxBody :: (MonadBlockChainBalancing m) => Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra -> TxSkel -> m (Cardano.TxBody Cardano.ConwayEra)
-txBodyContentToTxBody txBodyContent skel = do
+txBodyContentToTxBody :: (MonadBlockChainBalancing m) => Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra -> m (Cardano.TxBody Cardano.ConwayEra)
+txBodyContentToTxBody txBodyContent = do
   params <- getParams
   -- We create the associated Shelley TxBody
-  txBody@(Cardano.ShelleyTxBody a body c dats e f) <-
-    either
-      (throwError . MCEToCardanoError "generateTx :")
-      return
-      (Emulator.createTransactionBody params (Ledger.CardanoBuildTx txBodyContent))
-
-  -- There is a chance that the body is in need of additional data. This happens
-  -- when the set of reference inputs contains hashed datums that will need to
-  -- be resolved during phase 2 validation. All that follows aims at doing just
-  -- that. In the process, we have to reconstruct the body with the new data and
-  -- the associated hash. Hopefully, in the future, cardano-api provides a way
-  -- to add those data in the body directly without requiring this method, which
-  -- somewhat feels like a hack.
-
-  -- We gather the datums of the reference inputs in the skeleton
-  refIns <- forM (txSkelReferenceTxOutRefs skel) $ fmap (view txSkelOutDatumL) . unsafeTxOutByRef
-  -- We collect the additional data of the hashed datums as a map
-  let additionalDataMap =
-        Map.fromList [(Cardano.hashData dat, dat) | TxSkelOutSomeDatum (Cardano.Data . Api.toData -> dat) (Hashed _) <- refIns]
-  -- We return the body directly if no additional data is required
-  if null additionalDataMap
-    then return txBody
-    else do
-      -- We retrieve a needed parameter to process difference plutus languages
-      toLangDepViewParam <- Conway.getLanguageView . Cardano.unLedgerProtocolParameters . Emulator.ledgerProtocolParameters <$> getParams
-      -- We convert our data map into a 'TxDats'
-      let txDats' = Alonzo.TxDats additionalDataMap
-          -- We compute the new era, datums and redeemers based on the current dats
-          -- in the body and the additional data to include in the body.
-          (era, datums, redeemers) = case dats of
-            Cardano.TxBodyNoScriptData -> (Cardano.AlonzoEraOnwardsConway, txDats', Alonzo.Redeemers Map.empty)
-            Cardano.TxBodyScriptData era' txDats reds -> (era', txDats <> txDats', reds)
-          -- We collect the various witnesses in the body
-          witnesses = Cardano.collectTxBodyScriptWitnesses Cardano.ShelleyBasedEraConway txBodyContent
-          -- We collect their languages and convert them to Ledger languages
-          languages =
-            [ Cardano.toAlonzoScriptLanguage (Cardano.AnyPlutusScriptVersion v)
-              | (_, Cardano.AnyScriptWitness (Cardano.PlutusScriptWitness _ v _ _ _ _)) <- witnesses
-            ]
-          -- We compute the new script integrity hash with the added data
-          scriptIntegrityHash =
-            Cardano.alonzoEraOnwardsConstraints era $
-              Alonzo.hashScriptIntegrity (Set.fromList $ toLangDepViewParam <$> languages) redeemers datums
-          -- We wrap all of this in the new body
-          body' = body & Alonzo.scriptIntegrityHashTxBodyL Lens..~ scriptIntegrityHash
-      return $ Cardano.ShelleyTxBody a body' c (Cardano.TxBodyScriptData era datums redeemers) e f
+  either
+    (throwError . MCEToCardanoError "generateTx :")
+    return
+    (Emulator.createTransactionBody params (Ledger.CardanoBuildTx txBodyContent))
 
 -- | Generates an index with utxos known to a 'TxSkel'
 txSkelToIndex :: (MonadBlockChainBalancing m) => TxSkel -> Maybe (Set Api.TxOutRef, Wallet) -> m (Cardano.UTxO Cardano.ConwayEra)
@@ -156,9 +100,9 @@ txSkelToIndex txSkel mCollaterals = do
         Nothing -> []
         Just (s, _) -> Set.toList s
   -- We retrieve all the outputs known to the skeleton
-  (knownTxORefs, knownTxOuts) <- unzip . Map.toList <$> lookupUtxos (txSkelKnownTxOutRefs txSkel <> collateralIns)
+  (knownTxORefs, knownTxOuts) <- unzip . Map.toList <$> lookupUtxos (Set.toList (txSkelKnownTxOutRefs txSkel) <> collateralIns)
   -- We then compute their Cardano counterparts
-  txOutL <- forM knownTxOuts Output.toCardanoTxOut
+  txOutL <- forM knownTxOuts toCardanoTxOut
   -- We build the index and handle the possible error
   either (throwError . MCEToCardanoError "txSkelToIndex:") return $ do
     txInL <- forM knownTxORefs Ledger.toCardanoTxIn
@@ -171,9 +115,9 @@ txSkelToTxBody :: (MonadBlockChainBalancing m) => TxSkel -> Integer -> Maybe (Se
 txSkelToTxBody txSkel fee mCollaterals = do
   -- We create a first body content and body, without execution units
   txBodyContent' <- txSkelToTxBodyContent txSkel fee mCollaterals
-  txBody' <- txBodyContentToTxBody txBodyContent' txSkel
+  txBody' <- txBodyContentToTxBody txBodyContent'
   -- We create a full transaction from the body
-  let tx' = Cardano.Tx txBody' (Witness.toKeyWitness txBody' <$> txSkelSigners txSkel)
+  let tx' = Cardano.Tx txBody' (toKeyWitness txBody' <$> txSkelSigners txSkel)
   -- We retrieve the index and parameters to feed to @getTxExUnitsWithLogs@
   index <- txSkelToIndex txSkel mCollaterals
   params <- getParams
@@ -191,4 +135,4 @@ txSkelToTxBody txSkel fee mCollaterals = do
         Left _ -> throwError $ FailWith "Error while assigning execution units"
         -- We now have a body content with proper execution units and can create
         -- the final body from it
-        Right txBody -> txBodyContentToTxBody txBody txSkel
+        Right txBody -> txBodyContentToTxBody txBody

src/Cooked/MockChain/GenerateTx/ReferenceInputs.hs

@@ -0,0 +1,38 @@
+-- | This module allows the generation of Cardano reference inputs
+module Cooked.MockChain.GenerateTx.ReferenceInputs (toInsReference) where
+
+import Cardano.Api qualified as Cardano
+import Cooked.MockChain.BlockChain
+import Cooked.MockChain.GenerateTx.Common
+import Cooked.Skeleton
+import Data.Map qualified as Map
+import Data.Set qualified as Set
+import Ledger.Tx.CardanoAPI qualified as Ledger
+import PlutusLedgerApi.V3 qualified as Api
+
+-- | Takes a 'TxSkel' and generates the associated 'Cardano.TxInsReference' from
+-- its content. These reference inputs can be found in two places, either in
+-- direct reference inputs 'txSkelInsReference' or scattered in the various
+-- redeemers of the transaction, which can be gathered with
+-- 'txSkelInsReferenceInRedeemers'.
+toInsReference :: (MonadBlockChainBalancing m) => TxSkel -> m (Cardano.TxInsReference Cardano.BuildTx Cardano.ConwayEra)
+toInsReference skel = do
+  -- As regular inputs can be used to hold scripts as if in reference inputs, we
+  -- need to remove from the reference inputs stored in redeemers the ones that
+  -- already appear in the inputs to avoid validation errors.
+  let indirectReferenceInputs = txSkelInsReferenceInRedeemers skel
+      redundantReferenceInputs = indirectReferenceInputs `Set.intersection` Map.keysSet (txSkelIns skel)
+      refInputs = Set.toList (txSkelInsReference skel <> indirectReferenceInputs `Set.difference` redundantReferenceInputs)
+  if null refInputs
+    then return Cardano.TxInsReferenceNone
+    else do
+      cardanoRefInputs <-
+        throwOnToCardanoError
+          "toInsReference: Unable to translate reference inputs."
+          (mapM Ledger.toCardanoTxIn refInputs)
+      resolvedOutputs <- mapM unsafeDatumFromTxOutRef refInputs
+      return $
+        Cardano.TxInsReference Cardano.BabbageEraOnwardsConway cardanoRefInputs $
+          Cardano.BuildTxWith $
+            Set.fromList
+              [Ledger.toCardanoScriptData $ Api.toBuiltinData dat | TxSkelOutSomeDatum dat (Hashed _) <- resolvedOutputs]