Add evaluateTransaction and evaluateSignedTx to Cardano.Api.Experimental, composing script evaluation, fee computation, and balance checking into a single pure function for signed transactions.

Author: carbolymer

cardano-api/src/Cardano/Api/Experimental.hs

@@ -22,12 +22,17 @@ module Cardano.Api.Experimental
   , obtainCommonConstraints
   , eraProtVerHigh
   , hashTxBody
-  , evaluateTransactionExecutionUnits
-  , evaluateTransactionExecutionUnitsShelley
   , AnchorDataFromCertificateError (..)
   , getAnchorDataFromCertificate
   , mkTxCertificates
 
+    -- ** Transaction evaluation
+  , evaluateTransaction
+  , evaluateSignedTx
+  , TxEvaluationResult (..)
+  , evaluateTransactionExecutionUnits
+  , evaluateTransactionExecutionUnitsShelley
+
     -- ** Transaction fee related
   , FeeCalculationError (..)
   , calcMinFeeRecursive

cardano-api/src/Cardano/Api/Experimental/Tx.hs

@@ -193,9 +193,14 @@ module Cardano.Api.Experimental.Tx
   , getTxScriptWitnessesRequirements
   , obtainMonoidConstraint
 
+    -- * Transaction evaluation
+  , evaluateTransaction
+  , evaluateSignedTx
+  , TxEvaluationResult (..)
+  , evaluateTransactionExecutionUnits
+
     -- * Balancing transactions
   , calculateMinimumUTxO
-  , evaluateTransactionExecutionUnits
   , makeTransactionBodyAutoBalance
   , TxBodyErrorAutoBalance (..)
   , TxFeeEstimationError (..)
@@ -212,6 +217,8 @@ module Cardano.Api.Experimental.Tx
   )
 where
 
+import Cardano.Api.Address (StakeCredential)
+import Cardano.Api.Certificate.Internal (PoolId)
 import Cardano.Api.Era.Internal.Core qualified as Api
 import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra
 import Cardano.Api.Experimental.Era
@@ -225,6 +232,7 @@ import Cardano.Api.Ledger.Internal.Reexport qualified as L
 import Cardano.Api.Plutus.Internal.Script qualified as Api
 import Cardano.Api.Pretty (docToString, pretty)
 import Cardano.Api.ProtocolParameters
+import Cardano.Api.Query.Internal.Type.QueryInMode (LedgerEpochInfo, SystemStart)
 import Cardano.Api.Serialise.Raw
   ( SerialiseAsRawBytes (..)
   , SerialiseAsRawBytesError (SerialiseAsRawBytesError)
@@ -233,16 +241,18 @@ import Cardano.Api.Tx.Internal.Body qualified as Api
 import Cardano.Api.Tx.Internal.Sign
 
 import Cardano.Crypto.Hash qualified as Hash
+import Cardano.Ledger.Alonzo.Core qualified as Ledger
 import Cardano.Ledger.Api qualified as L
 import Cardano.Ledger.Binary qualified as Ledger
-import Cardano.Ledger.Core qualified as Ledger
+import Cardano.Ledger.Credential qualified as Ledger (Credential)
 import Cardano.Ledger.Hashes qualified as L hiding (Hash)
 
 import Control.Exception (displayException)
 import Data.Bifunctor (bimap)
 import Data.ByteString.Lazy (fromStrict)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
+import Data.Set (Set)
 import Data.Set qualified as Set
 import GHC.Stack
 import Lens.Micro
@@ -325,6 +335,39 @@ signTx era bootstrapWits shelleyKeyWits (UnsignedTx unsigned) =
         signedTx = unsigned & L.witsTxL .~ (keyWits <> currentScriptWitnesses)
      in SignedTx signedTx
 
+-- | Like 'evaluateTransaction' but accepts a 'SignedTx' directly.
+evaluateSignedTx
+  :: forall era
+   . IsEra era
+  => SystemStart
+  -- ^ Start time of the blockchain
+  -> LedgerEpochInfo
+  -- ^ Epoch info for slot/time conversions
+  -> L.PParams (LedgerEra era)
+  -- ^ Protocol parameters
+  -> Set PoolId
+  -- ^ Registered stake pools
+  -> Map StakeCredential L.Coin
+  -- ^ Stake delegation deposits
+  -> Map (Ledger.Credential Ledger.DRepRole) L.Coin
+  -- ^ DRep delegation deposits
+  -> L.UTxO (LedgerEra era)
+  -- ^ UTxO set for the transaction inputs
+  -> SignedTx era
+  -- ^ Signed transaction to evaluate
+  -> TxEvaluationResult (LedgerEra era)
+evaluateSignedTx systemStart epochInfo protocolParams poolIds stakeDelegDeposits drepDelegDeposits utxo (SignedTx tx) =
+  obtainCommonConstraints (useEra @era) $
+    evaluateTransaction
+      systemStart
+      epochInfo
+      protocolParams
+      poolIds
+      stakeDelegDeposits
+      drepDelegDeposits
+      utxo
+      tx
+
 -- Compatibility related. Will be removed once the old api has been deprecated and deleted.
 
 convertTxBodyToUnsignedTx

cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs

@@ -20,6 +20,8 @@ module Cardano.Api.Experimental.Tx.Internal.Fee
   , calcMinFeeRecursive
   , collectTxBodyScriptWitnesses
   , estimateBalancedTxBody
+  , evaluateTransaction
+  , TxEvaluationResult (..)
   , evaluateTransactionExecutionUnits
   , evaluateTransactionFee
   , indexWitnessedTxProposalProcedures
@@ -45,14 +47,15 @@ import Cardano.Api.Experimental.Tx.Internal.Type
 import Cardano.Api.Key.Internal qualified as Api
 import Cardano.Api.Ledger.Internal.Reexport qualified as L
 import Cardano.Api.Plutus.Internal
-import Cardano.Api.Plutus.Internal.Script (fromAlonzoExUnits)
+import Cardano.Api.Plutus.Internal.Script (fromAlonzoExUnits, toAlonzoExUnits)
 import Cardano.Api.Plutus.Internal.Script qualified as Old
 import Cardano.Api.Plutus.Internal.ScriptData
 import Cardano.Api.Pretty
 import Cardano.Api.ProtocolParameters
 import Cardano.Api.Query.Internal.Type.QueryInMode
 import Cardano.Api.Tx.Internal.Body
   ( ScriptWitnessIndex (..)
+  , fromScriptWitnessIndex
   , indexCertificatesWith
   , renderScriptWitnessIndex
   , toScriptIndex
@@ -93,7 +96,7 @@ import Data.Set (Set)
 import Data.Set qualified as Set
 import GHC.Exts (IsList (..))
 import GHC.Stack
-import Lens.Micro ((.~), (^.))
+import Lens.Micro ((%~), (.~), (^.))
 import Prettyprinter (punctuate)
 
 data TxBodyErrorAutoBalance era
@@ -532,6 +535,86 @@ calculateMinimumUTxO pp (TxOut txout) =
   let txOutWithMinCoin = L.setMinCoinTxOut pp txout
    in txOutWithMinCoin ^. L.coinTxOutL
 
+-- | Result of evaluating a signed transaction against the current ledger state.
+data TxEvaluationResult era = Show (L.Value era) => TxEvaluationResult
+  { txEvalFee :: L.Coin
+  -- ^ Computed minimum fee for the transaction
+  , txEvalExecutionUnits
+      :: Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
+  -- ^ Per-redeemer execution units or script errors
+  , txEvalBalance :: L.Value era
+  -- ^ Remaining balance (consumed - produced); mempty when balanced
+  }
+
+deriving instance Show (TxEvaluationResult era)
+
+-- | Run all scripts, compute the minimum fee, and check the balance.
+evaluateTransaction
+  :: forall era
+   . IsEra era
+  => SystemStart
+  -- ^ Start time of the blockchain
+  -> LedgerEpochInfo
+  -- ^ Epoch info for slot/time conversions
+  -> L.PParams (LedgerEra era)
+  -- ^ Protocol parameters
+  -> Set PoolId
+  -- ^ Registered stake pools
+  -> Map StakeCredential L.Coin
+  -- ^ Stake delegation deposits
+  -> Map (Ledger.Credential Ledger.DRepRole) L.Coin
+  -- ^ DRep delegation deposits
+  -> L.UTxO (LedgerEra era)
+  -- ^ UTxO set for the transaction inputs
+  -> L.Tx L.TopTx (LedgerEra era)
+  -- ^ Signed transaction to evaluate
+  -> TxEvaluationResult (LedgerEra era)
+evaluateTransaction systemStart epochInfo protocolParams poolIds stakeDelegDeposits drepDelegDeposits utxo tx =
+  obtainCommonConstraints (useEra @era) $ do
+    let txEvalExecutionUnits =
+          evaluateTransactionExecutionUnits systemStart epochInfo protocolParams utxo tx
+        evaluatedExUnitsMap =
+          Map.fromList
+            [ (purpose, toAlonzoExUnits units)
+            | (scriptWitnessIndex, Right (_, units)) <- Map.toList txEvalExecutionUnits
+            , Just purpose <- [fromScriptWitnessIndex (convert $ useEra @era) scriptWitnessIndex]
+            ]
+        txWithEvaluatedExUnits =
+          tx
+            & L.witsTxL . L.rdmrsTxWitsL
+              %~ \redeemers ->
+                L.Redeemers
+                  . Map.mapWithKey
+                    ( \purpose (datum, oldExUnits) ->
+                        (datum, Map.findWithDefault oldExUnits purpose evaluatedExUnitsMap)
+                    )
+                  $ L.unRedeemers redeemers
+        txEvalFee =
+          L.setMinFeeTxUtxo protocolParams txWithEvaluatedExUnits utxo
+            ^. L.bodyTxL . L.feeTxBodyL
+        txEvalBalance =
+          L.evalBalanceTxBody
+            protocolParams
+            lookupDelegDeposit
+            lookupDRepDeposit
+            isRegPool
+            utxo
+            $ txWithEvaluatedExUnits ^. L.bodyTxL
+    TxEvaluationResult{txEvalFee, txEvalExecutionUnits, txEvalBalance}
+ where
+  isRegPool :: Ledger.KeyHash Ledger.StakePool -> Bool
+  isRegPool keyHash = Api.StakePoolKeyHash keyHash `Set.member` poolIds
+
+  lookupDelegDeposit
+    :: Ledger.Credential Ledger.Staking -> Maybe L.Coin
+  lookupDelegDeposit stakeCred =
+    Map.lookup (fromShelleyStakeCredential stakeCred) stakeDelegDeposits
+
+  lookupDRepDeposit
+    :: Ledger.Credential Ledger.DRepRole -> Maybe L.Coin
+  lookupDRepDeposit drepCred =
+    Map.lookup drepCred drepDelegDeposits
+
 -- | Compute the total balance of the proposed transaction. Ultimately, a valid
 -- transaction must be fully balanced, which means that it has a total value
 -- of zero.

cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs

@@ -108,6 +108,18 @@ tests =
             "underfunded transaction fails with TxBodyErrorBalanceNegative"
             prop_makeTransactionBodyAutoBalance_balance_negative
         ]
+    , testGroup
+        "evaluateTransaction"
+        [ testProperty
+            "well-funded simple tx returns positive fee"
+            prop_evaluateTransaction_positive_fee
+        , testProperty
+            "script-free tx returns empty execution units map"
+            prop_evaluateTransaction_no_scripts_empty_exunits
+        , testProperty
+            "balanced tx has mempty balance"
+            prop_evaluateTransaction_balanced_mempty
+        ]
     ]
 
 -- ---------------------------------------------------------------------------
@@ -736,6 +748,70 @@ prop_makeTransactionBodyAutoBalance_balance_negative = H.property $ do
       H.annotate "Expected TxBodyErrorBalanceNegative but tx balanced successfully"
         >> H.failure
 
+-- | A well-funded transaction returns a positive fee from 'evaluateTransaction'.
+prop_evaluateTransaction_positive_fee :: Property
+prop_evaluateTransaction_positive_fee = H.property $ do
+  (result, _utxo, _unsignedTx, _changeAddr) <- H.forAll evalSimpleTx
+  H.assertWith (Exp.txEvalFee result) (> L.Coin 0)
+
+-- | A script-free transaction returns an empty execution units map.
+prop_evaluateTransaction_no_scripts_empty_exunits :: Property
+prop_evaluateTransaction_no_scripts_empty_exunits = H.property $ do
+  (result, _utxo, _unsignedTx, _changeAddr) <- H.forAll evalSimpleTx
+  H.assertWith (Exp.txEvalExecutionUnits result) Map.null
+
+-- | A transaction balanced by 'calcMinFeeRecursive' has mempty balance
+-- when checked by 'evaluateSignedTx'.
+prop_evaluateTransaction_balanced_mempty :: Property
+prop_evaluateTransaction_balanced_mempty = H.property $ do
+  (unsignedTx, utxo, changeAddr) <- H.forAll $ genFundedSimpleTx Exp.ConwayEra
+  Exp.UnsignedTx balancedLedgerTx <-
+    H.leftFail $
+      Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0
+  let signedTx = Exp.SignedTx balancedLedgerTx
+      systemStart = Api.SystemStart $ Time.posixSecondsToUTCTime 0
+      epochInfo =
+        Api.LedgerEpochInfo $
+          Slotting.fixedEpochInfo (Slotting.EpochSize 100) (Slotting.mkSlotLength 1000)
+      result =
+        Exp.evaluateSignedTx
+          systemStart
+          epochInfo
+          exampleProtocolParams
+          mempty
+          mempty
+          mempty
+          utxo
+          signedTx
+  Exp.txEvalBalance result H.=== mempty
+
+-- | Evaluate a simple signed transaction, returning the result and UTxO.
+evalSimpleTx
+  :: Gen
+       ( Exp.TxEvaluationResult (Exp.LedgerEra Exp.ConwayEra)
+       , L.UTxO (Exp.LedgerEra Exp.ConwayEra)
+       , Exp.UnsignedTx (Exp.LedgerEra Exp.ConwayEra)
+       , L.Addr
+       )
+evalSimpleTx = do
+  (unsignedTx, utxo, changeAddr) <- genFundedSimpleTx Exp.ConwayEra
+  let signedTx = Exp.signTx Exp.ConwayEra [] [] unsignedTx
+      systemStart = Api.SystemStart $ Time.posixSecondsToUTCTime 0
+      epochInfo =
+        Api.LedgerEpochInfo $
+          Slotting.fixedEpochInfo (Slotting.EpochSize 100) (Slotting.mkSlotLength 1000)
+      result =
+        Exp.evaluateSignedTx
+          systemStart
+          epochInfo
+          exampleProtocolParams
+          mempty
+          mempty
+          mempty
+          utxo
+          signedTx
+  pure (result, utxo, unsignedTx, changeAddr)
+
 -- | Regression test for the bug where 'mapScriptWitnessesCertificates' silently
 -- dropped certs stored with a @Nothing@ witness (e.g. shelley stake registration
 -- certificates) when rebuilding 'TxCertificates' during fee balancing.

cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Eval.hs

@@ -82,35 +82,18 @@ evalTxMethod request = do
   obtainCommonConstraints eon $ do
     let ledgerUtxo = toLedgerUTxO (convert eon) utxo
         epochInfo = toLedgerEpochInfo eraHistory
-        evalResults =
-          Exp.evaluateTransactionExecutionUnits
+        drepDeposits = Map.map (L.fromCompact . L.drepDeposit) drepStates
+        poolIdSet = Map.keysSet registeredPools
+        Exp.TxEvaluationResult fee evalUnits balance =
+          Exp.evaluateTransaction
             systemStart
             epochInfo
             protocolParams
+            poolIdSet
+            stakeDelegDeposits
+            drepDeposits
             ledgerUtxo
             ledgerTx
-        evaluatedExUnitsMap =
-          Map.fromList
-            [ (purpose, L.ExUnits (executionMemory units) (executionSteps units))
-            | (swi, Right (_, units)) <- Map.toList evalResults
-            , Just purpose <- [fromScriptWitnessIndex (convert eon) swi]
-            ]
-        -- Failed redeemers keep the client-supplied ex-units, so the computed
-        -- fee may vary with the client's guess. This is acceptable because a
-        -- failed evaluation means the tx cannot be submitted anyway.
-        txWithEvaluatedExUnits =
-          ledgerTx
-            & L.witsTxL . L.rdmrsTxWitsL
-              %~ \rdmrs ->
-                L.Redeemers $
-                  Map.mapWithKey
-                    ( \purpose (datum, oldExUnits) ->
-                        (datum, Map.findWithDefault oldExUnits purpose evaluatedExUnitsMap)
-                    )
-                    (L.unRedeemers rdmrs)
-        fee =
-          L.setMinFeeTxUtxo protocolParams txWithEvaluatedExUnits ledgerUtxo
-            ^. L.bodyTxL . L.feeTxBodyL
         redeemerData =
           Map.fromList
             [ ( toScriptIndex (convert eon) purpose
@@ -122,22 +105,7 @@ evalTxMethod request = do
             | (purpose, (datum, _exUnits)) <-
                 toList . L.unRedeemers $ ledgerTx ^. L.witsTxL . L.rdmrsTxWitsL
             ]
-        txEval = mkProtoTxEval fee evalResults redeemerData
-
-        lookupStakeDeposit credential =
-          Map.lookup (fromShelleyStakeCredential credential) stakeDelegDeposits
-        lookupDRepDeposit credential =
-          L.fromCompact . L.drepDeposit <$> Map.lookup credential drepStates
-        isRegPool poolKeyHash =
-          StakePoolKeyHash poolKeyHash `Map.member` registeredPools
-        balance =
-          L.evalBalanceTxBody
-            protocolParams
-            lookupStakeDeposit
-            lookupDRepDeposit
-            isRegPool
-            ledgerUtxo
-            (txWithEvaluatedExUnits ^. L.bodyTxL)
+        txEval = mkProtoTxEval fee evalUnits redeemerData
         balanceErrors
           | balance == mempty = []
           | otherwise =