diff --git a/.changes/20260515_cardano_api_evaluate_transaction.yml b/.changes/20260515_cardano_api_evaluate_transaction.yml new file mode 100644 index 0000000000..9691351b84 --- /dev/null +++ b/.changes/20260515_cardano_api_evaluate_transaction.yml @@ -0,0 +1,6 @@ +project: cardano-api +pr: 1205 +kind: + - feature +description: | + Add `evaluateTransaction` and `evaluateSignedTx` to `Cardano.Api.Experimental`, composing script evaluation, fee computation, and balance checking into a single pure function for signed transactions. diff --git a/.changes/20260515_cardano_rpc_use_evaluate_transaction.yml b/.changes/20260515_cardano_rpc_use_evaluate_transaction.yml new file mode 100644 index 0000000000..6661059d5f --- /dev/null +++ b/.changes/20260515_cardano_rpc_use_evaluate_transaction.yml @@ -0,0 +1,6 @@ +project: cardano-rpc +pr: 1205 +kind: + - refactoring +description: | + Refactor `evalTxMethod` to use the new `Exp.evaluateTransaction` from cardano-api instead of inlining the script evaluation, fee computation, and balance checking pipeline. diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index 16498616f0..687e3b2ddd 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/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 diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx.hs b/cardano-api/src/Cardano/Api/Experimental/Tx.hs index 779934ad1f..2620d4cac5 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx.hs +++ b/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,9 +241,10 @@ 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) @@ -243,6 +252,7 @@ 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,41 @@ 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 is needed here to bring ShelleyLedgerEra era ~ LedgerEra era + -- into scope, unifying SignedTx's ShelleyLedgerEra with evaluateTransaction's LedgerEra. + 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 diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs index 1ce6a27568..3f872484d4 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/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,7 +47,7 @@ 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 @@ -53,6 +55,7 @@ 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. diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs index 398ca83c96..483a2bd05f 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs +++ b/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_evaluateSignedTx_balanced_mempty + ] ] -- --------------------------------------------------------------------------- @@ -736,6 +748,73 @@ 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 whose fee was set by 'calcMinFeeRecursive' has mempty +-- balance when checked by 'evaluateSignedTx', because the generator +-- produces a tx whose inputs exactly cover outputs plus the computed fee. +-- Witnesses are irrelevant for balance checking, so we wrap the ledger tx +-- directly in 'SignedTx' without calling 'signTx'. +prop_evaluateSignedTx_balanced_mempty :: Property +prop_evaluateSignedTx_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. diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Eval.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Eval.hs index 8596b56061..57851da6a8 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Eval.hs +++ b/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 =