From d85b85e33cfa2444a75c4a5035dbb40721252c50 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 29 Jan 2026 13:50:49 -0400 Subject: [PATCH 01/12] Recursive fee calc --- cardano-api/cardano-api.cabal | 2 + cardano-api/src/Cardano/Api/Experimental.hs | 2 + .../Api/Experimental/Tx/Internal/Fee.hs | 57 ++++++++++++++++- .../Test/Cardano/Api/Experimental.hs | 61 ++++++++++++++++++- 4 files changed, 117 insertions(+), 5 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index ecf4443aac..590fd32796 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -367,6 +367,7 @@ test-suite cardano-api-test cardano-crypto-wrapper:testlib, cardano-ledger-alonzo, cardano-ledger-api ^>=1.12.1, + cardano-ledger-babbage, cardano-ledger-binary, cardano-ledger-conway, cardano-ledger-core >=1.14, @@ -374,6 +375,7 @@ test-suite cardano-api-test cardano-ledger-shelley, cardano-protocol-tpraos, cardano-slotting, + cardano-strict-containers, cborg, containers, data-default, diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index e2241a34d9..889443e087 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -25,6 +25,8 @@ module Cardano.Api.Experimental , mkTxCertificates -- ** Transaction fee related + , RecursiveFeeCalculationError (..) + , calcMinFeeRecursive , estimateBalancedTxBody , evaluateTransactionFee , collectTxBodyScriptWitnesses 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 f6c526107c..60708ba00e 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs @@ -13,9 +13,11 @@ {-# LANGUAGE TypeApplications #-} module Cardano.Api.Experimental.Tx.Internal.Fee - ( TxBodyErrorAutoBalance (..) + ( RecursiveFeeCalculationError (..) + , TxBodyErrorAutoBalance (..) , TxFeeEstimationError (..) , calculateMinimumUTxO + , calcMinFeeRecursive , collectTxBodyScriptWitnesses , estimateBalancedTxBody , evaluateTransactionExecutionUnits @@ -83,11 +85,12 @@ import Data.Maybe import Data.OSet.Strict qualified as OSet import Data.Ord (Down (Down), comparing) import Data.Ratio +import Data.Sequence.Strict qualified as Seq 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 @@ -657,6 +660,56 @@ evaluateTransactionFee evaluateTransactionFee pp (UnsignedTx tx) keywitcount byronwitcount refScriptsSize = L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize +newtype RecursiveFeeCalculationError = NotEnoughAda Coin deriving (Show, Eq) + +instance Error RecursiveFeeCalculationError where + prettyError (NotEnoughAda balance) = + mconcat + [ "The transaction balance is negative: " + , pretty balance + , "\nThis means that the transaction does not have enough ada to cover the fees. The usual solution is to provide more inputs, or inputs with more ada." + ] + +calcMinFeeRecursive + :: forall era + . IsEra era + => UnsignedTx (LedgerEra era) + -> L.UTxO (LedgerEra era) + -> L.PParams (LedgerEra era) + -> Int + -- ^ Number of extra key hashes for native scripts + -> Either RecursiveFeeCalculationError (UnsignedTx (LedgerEra era)) +calcMinFeeRecursive unSignTx@(UnsignedTx ledgerTx) utxo pparams nExtraWitnesses + | minFee == txBodyFee && L.isZero txBalanceCoin = + -- We have reached the minimum fee but there isn't a guarantee that + -- the inputs/outputs are balanced + return unSignTx + | minFee == txBodyFee && txBalanceCoin > 0 = + -- We have a surplus balance so we modify the outputs to include it. + let balancedOuts = balanceTxOuts txBalanceValue unSignTx + updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ Seq.fromList balancedOuts) + in return updatedTx + | txBalanceCoin < 0 = Left $ NotEnoughAda txBalanceCoin + | otherwise = + let newTx = UnsignedTx (ledgerTx & L.bodyTxL . L.feeTxBodyL .~ minFee) + in calcMinFeeRecursive newTx utxo pparams nExtraWitnesses + where + minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo pparams ledgerTx nExtraWitnesses + txBodyFee = ledgerTx ^. L.bodyTxL . L.feeTxBodyL + txBalanceValue = evaluateTransactionBalance pparams mempty mempty mempty utxo unSignTx + txBalanceCoin = L.coin txBalanceValue + +balanceTxOuts + :: L.Value (LedgerEra era) + -> UnsignedTx (LedgerEra era) + -> [L.TxOut (LedgerEra era)] +balanceTxOuts txBalance (UnsignedTx tx) = + let outs = toList $ tx ^. L.bodyTxL . L.outputsTxBodyL + split = List.uncons outs + (h, rest) = maybe (error "calcMinFeeRecursive: No outs!") id split + updatedout = h & L.valueTxOutL %~ (<> txBalance) + in updatedout : rest + -- Essentially we check for the existence of collateral inputs. If they exist we -- create a fictitious collateral return output. Why? Because we need to put dummy values -- to get a fee estimate (i.e we overestimate the fee). The required collateral depends diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index 51b9dec4f1..dd0be4a6d8 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -15,24 +15,34 @@ import Cardano.Api.Experimental qualified as Exp import Cardano.Api.Experimental.Era (convert) import Cardano.Api.Experimental.Tx qualified as Exp import Cardano.Api.Genesis qualified as Genesis +import Cardano.Api.Ledger qualified as L import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Parser.Text qualified as Api import Cardano.Api.Plutus qualified as Script import Cardano.Api.Tx (Tx (ShelleyTx)) +import Cardano.Ledger.Address qualified as L import Cardano.Ledger.Alonzo.Scripts qualified as UnexportedLedger import Cardano.Ledger.Api qualified as UnexportedLedger +import Cardano.Ledger.Babbage.TxBody qualified as L +import Cardano.Ledger.Conway qualified as L +import Cardano.Ledger.Core qualified as L +import Cardano.Ledger.Credential qualified as L +import Cardano.Ledger.Plutus.Data qualified as L import Cardano.Slotting.EpochInfo qualified as Slotting import Cardano.Slotting.Slot qualified as Slotting import Cardano.Slotting.Time qualified as Slotting import Control.Monad.Identity (Identity) import Data.Bifunctor (first) +import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) +import Data.Maybe.Strict (StrictMaybe (..)) import Data.Ratio ((%)) import Data.Text.Encoding qualified as Text import Data.Time qualified as Time import Data.Time.Clock.POSIX qualified as Time -import Lens.Micro ((&)) +import Lens.Micro import Test.Gen.Cardano.Api.Typed (genTx) @@ -126,10 +136,55 @@ prop_balance_transaction_two_ways = H.propertyOnce $ do -- Old API let oldFees = Api.evaluateTransactionFee sbe exampleProtocolParams txBody 0 1 0 -- NEW API - newFees = Exp.evaluateTransactionFee exampleProtocolParams (Exp.makeUnsignedTx era newTxBodyContent) 0 1 0 + unSignTx = Exp.makeUnsignedTx era newTxBodyContent + newFees = Exp.evaluateTransactionFee exampleProtocolParams unSignTx 0 1 0 + + -- Recursive calc + dummyTxIn <- + H.evalEither + ( Api.toShelleyTxIn + <$> Api.runParser + Api.parseTxIn + "be6efd42a3d7b9a00d09d77a5d41e55ceaf0bd093a8aa8a893ce70d9caafd978#0" + ) + + let paymentCredential :: L.PaymentCredential + paymentCredential = + L.KeyHashObj $ + L.KeyHash + "1c14ee8e58fbcbd48dc7367c95a63fd1d937ba989820015db16ac7e5" + + stakingCredential :: L.StakeCredential + stakingCredential = + L.KeyHashObj $ + L.KeyHash + "e37a65ea2f9bcefb645de4312cf13d8ac12ae61cf242a9aa2973c9ee" + initialFundedAddress :: L.Addr + initialFundedAddress = L.Addr L.Testnet paymentCredential (L.StakeRefBase stakingCredential) + dummyLargeTxOut :: L.BabbageTxOut L.ConwayEra = + Exp.obtainCommonConstraints era $ + L.BabbageTxOut + initialFundedAddress + (L.MaryValue (L.Coin 12_000_000) mempty) + L.NoDatum + SNothing + + dummyUTxO = L.UTxO $ Map.singleton dummyTxIn dummyLargeTxOut + Exp.UnsignedTx recFeeTx <- + H.evalEither $ Exp.calcMinFeeRecursive unSignTx dummyUTxO exampleProtocolParams 0 + let recFee = recFeeTx ^. (L.bodyTxL . L.feeTxBodyL) H.note_ $ "Fees 1: " <> show oldFees - oldFees H.=== newFees + oldFees H.=== L.Coin 236 + + newFees H.=== L.Coin 236 + + -- Recursive fee calculation appears result in fees that are ~ 20% lower + recFee H.=== L.Coin 193 + + H.assert $ recFee < oldFees + + H.assert $ recFee < newFees -- Balance without ledger context (other that protocol parameters) -- Old api From 1a2b854cae405f31b19dbbb9621385b75887e14e Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 12 Feb 2026 14:06:47 -0400 Subject: [PATCH 02/12] Add property tests for calcMinFeeRecursive MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Three Hedgehog properties in Test.Cardano.Api.Experimental verify the key invariants of the recursive fee calculator: - well-funded transaction always succeeds and produces a positive fee - fee calculation is idempotent (result is a fixed point) - underfunded transaction (outputs exceed inputs) always returns NotEnoughAda with a negative deficit coin Two lovelace-only generators drive the tests: one with generous UTxO funding (5–20 ADA input, 1–3 ADA output) and one where the output deliberately exceeds the input (0.5–2 ADA vs 5–10 ADA). --- .../Api/Experimental/Tx/Internal/Fee.hs | 24 ++-- .../Test/Cardano/Api/Experimental.hs | 118 +++++++++++++++++- 2 files changed, 132 insertions(+), 10 deletions(-) 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 60708ba00e..971eff69e4 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs @@ -660,7 +660,10 @@ evaluateTransactionFee evaluateTransactionFee pp (UnsignedTx tx) keywitcount byronwitcount refScriptsSize = L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize -newtype RecursiveFeeCalculationError = NotEnoughAda Coin deriving (Show, Eq) +data RecursiveFeeCalculationError + = NotEnoughAda Coin + | NoTxOuts + deriving (Show, Eq) instance Error RecursiveFeeCalculationError where prettyError (NotEnoughAda balance) = @@ -669,6 +672,8 @@ instance Error RecursiveFeeCalculationError where , pretty balance , "\nThis means that the transaction does not have enough ada to cover the fees. The usual solution is to provide more inputs, or inputs with more ada." ] + prettyError NoTxOuts = + "The transaction has no outputs. At least one output is required to balance the transaction." calcMinFeeRecursive :: forall era @@ -684,10 +689,10 @@ calcMinFeeRecursive unSignTx@(UnsignedTx ledgerTx) utxo pparams nExtraWitnesses -- We have reached the minimum fee but there isn't a guarantee that -- the inputs/outputs are balanced return unSignTx - | minFee == txBodyFee && txBalanceCoin > 0 = + | minFee == txBodyFee && txBalanceCoin > 0 = do -- We have a surplus balance so we modify the outputs to include it. - let balancedOuts = balanceTxOuts txBalanceValue unSignTx - updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ Seq.fromList balancedOuts) + balancedOuts <- balanceTxOuts txBalanceValue unSignTx + let updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ Seq.fromList balancedOuts) in return updatedTx | txBalanceCoin < 0 = Left $ NotEnoughAda txBalanceCoin | otherwise = @@ -702,13 +707,14 @@ calcMinFeeRecursive unSignTx@(UnsignedTx ledgerTx) utxo pparams nExtraWitnesses balanceTxOuts :: L.Value (LedgerEra era) -> UnsignedTx (LedgerEra era) - -> [L.TxOut (LedgerEra era)] + -> Either RecursiveFeeCalculationError [L.TxOut (LedgerEra era)] balanceTxOuts txBalance (UnsignedTx tx) = let outs = toList $ tx ^. L.bodyTxL . L.outputsTxBodyL - split = List.uncons outs - (h, rest) = maybe (error "calcMinFeeRecursive: No outs!") id split - updatedout = h & L.valueTxOutL %~ (<> txBalance) - in updatedout : rest + in case List.uncons outs of + Nothing -> Left NoTxOuts + Just (h, rest) -> + let updatedout = h & L.valueTxOutL %~ (<> txBalance) + in Right $ updatedout : rest -- Essentially we check for the existence of collateral inputs. If they exist we -- create a fictitious collateral return output. Why? Because we need to put dummy values diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index dd0be4a6d8..e078f5cfe5 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -44,13 +44,14 @@ import Data.Time qualified as Time import Data.Time.Clock.POSIX qualified as Time import Lens.Micro -import Test.Gen.Cardano.Api.Typed (genTx) +import Test.Gen.Cardano.Api.Typed (genAddressInEra, genTx, genTxIn) import Hedgehog (Gen, Property) import Hedgehog qualified as H import Hedgehog.Extras qualified as H import Hedgehog.Gen qualified as Gen import Hedgehog.Internal.Property qualified as H +import Hedgehog.Range qualified as Range import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -77,6 +78,18 @@ tests = , testProperty "Roundtrip SerialiseAsRawBytes SignedTx" prop_roundtrip_serialise_as_raw_bytes_signed_tx + , testGroup + "calcMinFeeRecursive" + [ testProperty + "well-funded transaction always succeeds" + prop_calcMinFeeRecursive_well_funded_succeeds + , testProperty + "fee calculation is idempotent" + prop_calcMinFeeRecursive_fee_fixpoint + , testProperty + "underfunded transaction (outputs exceed inputs) always fails" + prop_calcMinFeeRecursive_insufficient_funds + ] ] prop_created_transaction_with_both_apis_are_the_same :: Property @@ -494,3 +507,106 @@ prop_roundtrip_serialise_as_raw_bytes_signed_tx = H.withTests (H.TestLimit 20) $ signedTx (Text.decodeUtf8 . Api.serialiseToRawBytesHex) (first show . Api.deserialiseFromRawBytesHex . Text.encodeUtf8) + +-- --------------------------------------------------------------------------- +-- Property tests for calcMinFeeRecursive +-- --------------------------------------------------------------------------- + +-- | Generates a simple lovelace-only transaction with generous UTxO funding. +-- UTxO has 5-20 ADA, the single output has 1-3 ADA, leaving 2-19 ADA of +-- surplus that covers any realistic fee. +genFundedSimpleTx + :: Exp.Era era + -> Gen + ( Exp.UnsignedTx (Exp.LedgerEra era) + , L.UTxO (Exp.LedgerEra era) + ) +genFundedSimpleTx era = do + let sbe = convert era + txIn <- genTxIn + addr <- Api.toShelleyAddr <$> genAddressInEra sbe + fundingCoin <- L.Coin <$> Gen.integral (Range.linear 5_000_000 20_000_000) + sendCoin <- L.Coin <$> Gen.integral (Range.linear 1_000_000 3_000_000) + let ledgerTxIn = Api.toShelleyTxIn txIn + fundingTxOut = + Exp.obtainCommonConstraints era $ + L.mkBasicTxOut addr (L.MaryValue fundingCoin mempty) + utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut + sendTxOut = + Exp.obtainCommonConstraints era $ + Exp.TxOut $ + Exp.obtainCommonConstraints era $ + Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty) + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxOuts [sendTxOut] + & Exp.setTxFee 0 + return (Exp.makeUnsignedTx era txBodyContent, utxo) + +-- | Generates a simple lovelace-only transaction where the single output +-- (5-10 ADA) greatly exceeds the UTxO funding (0.5-2 ADA). +genUnderfundedTx + :: forall era + . Exp.Era era + -> Gen + ( Exp.UnsignedTx (Exp.LedgerEra era) + , L.UTxO (Exp.LedgerEra era) + ) +genUnderfundedTx era = do + let sbe = convert era + txIn <- genTxIn + addr <- Api.toShelleyAddr <$> genAddressInEra sbe + fundingCoin <- L.Coin <$> Gen.integral (Range.linear 500_000 2_000_000) + sendCoin <- L.Coin <$> Gen.integral (Range.linear 5_000_000 10_000_000) + let ledgerTxIn = Api.toShelleyTxIn txIn + fundingTxOut = + Exp.obtainCommonConstraints era $ + L.mkBasicTxOut addr (L.MaryValue fundingCoin mempty) + utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut + sendTxOut = + Exp.obtainCommonConstraints era $ + Exp.TxOut $ + Exp.obtainCommonConstraints era $ + Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty) + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxOuts [sendTxOut] + & Exp.setTxFee 0 + return (Exp.makeUnsignedTx era txBodyContent, utxo) + +-- | A well-funded transaction (UTxO >> output + fee) always produces a +-- successful positive fee calculation. +prop_calcMinFeeRecursive_well_funded_succeeds :: Property +prop_calcMinFeeRecursive_well_funded_succeeds = H.property $ do + (unsignedTx, utxo) <- H.forAll $ genFundedSimpleTx Exp.ConwayEra + case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of + Left err -> H.annotateShow err >> H.failure + Right (Exp.UnsignedTx resultLedgerTx) -> do + let resultFee = resultLedgerTx ^. L.bodyTxL . L.feeTxBodyL + H.assert $ resultFee > L.Coin 0 + +-- | 'calcMinFeeRecursive' is idempotent: applying it to its own result +-- yields the same 'UnsignedTx'. This confirms the fee has reached a +-- fixed point and that any surplus was already distributed to outputs. +prop_calcMinFeeRecursive_fee_fixpoint :: Property +prop_calcMinFeeRecursive_fee_fixpoint = H.property $ do + (unsignedTx, utxo) <- H.forAll $ genFundedSimpleTx Exp.ConwayEra + case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of + Left _ -> H.success + Right resultTx -> do + secondResult <- + H.evalEither $ + Exp.calcMinFeeRecursive resultTx utxo exampleProtocolParams 0 + resultTx H.=== secondResult + +-- | When the outputs exceed the UTxO value the function returns +-- 'Left (NotEnoughAda _)' with a negative deficit coin. +prop_calcMinFeeRecursive_insufficient_funds :: Property +prop_calcMinFeeRecursive_insufficient_funds = H.property $ do + (unsignedTx, utxo) <- H.forAll $ genUnderfundedTx Exp.ConwayEra + case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of + Left (Exp.NotEnoughAda deficit) -> H.assert $ deficit < L.Coin 0 + Left Exp.NoTxOuts -> H.annotate "Unexpected NoTxOuts error" >> H.failure + Right _ -> H.failure From dce1300e9df1b5471a12d1e4de92d977216e9c88 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Mon, 23 Feb 2026 19:50:11 +0100 Subject: [PATCH 03/12] Improve test generator to cover different CBOR encoding sizes Vary sendCoin values across CBOR unsigned integer encoding buckets (5-byte and 9-byte), including values near the 2^32 boundary, to exercise more serialization paths in the property tests. --- .../Test/Cardano/Api/Experimental.hs | 26 ++++++++++++++++--- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index e078f5cfe5..e0a14b0254 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -513,8 +513,11 @@ prop_roundtrip_serialise_as_raw_bytes_signed_tx = H.withTests (H.TestLimit 20) $ -- --------------------------------------------------------------------------- -- | Generates a simple lovelace-only transaction with generous UTxO funding. --- UTxO has 5-20 ADA, the single output has 1-3 ADA, leaving 2-19 ADA of --- surplus that covers any realistic fee. +-- @sendCoin@ values span different CBOR unsigned integer encoding sizes +-- (5-byte and 9-byte), including values near the 2^32 boundary. +-- The minimum UTxO requirement (~1 ADA) prevents values in the 1–3 byte ranges. +-- @fundingCoin = sendCoin + surplus@, where surplus is 2–17 ADA, ensuring the +-- transaction is always well-funded for any realistic fee. genFundedSimpleTx :: Exp.Era era -> Gen @@ -525,8 +528,23 @@ genFundedSimpleTx era = do let sbe = convert era txIn <- genTxIn addr <- Api.toShelleyAddr <$> genAddressInEra sbe - fundingCoin <- L.Coin <$> Gen.integral (Range.linear 5_000_000 20_000_000) - sendCoin <- L.Coin <$> Gen.integral (Range.linear 1_000_000 3_000_000) + -- CBOR unsigned integer encoding sizes: ≤23 → 1 byte, ≤255 → 2 bytes, + -- ≤65535 → 3 bytes, ≤4294967295 → 5 bytes, >4294967295 → 9 bytes. + -- Minimum UTxO (~1 ADA = 1_000_000 lovelace) constrains sendCoin to + -- the 5-byte range at minimum. + sendCoin <- + L.Coin + <$> Gen.choice + [ Gen.integral (Range.linear 1_000_000 3_000_000) -- 5-byte CBOR (low) + , Gen.integral (Range.linear 100_000_000 500_000_000) -- 5-byte CBOR (mid) + , Gen.integral (Range.linear 4_290_000_000 4_300_000_000) -- near 2^32 boundary + , Gen.integral (Range.linear 5_000_000_000 10_000_000_000) -- 9-byte CBOR + ] + -- Surplus of 2–17 ADA ensures funding always exceeds sendCoin + fees. + -- Fees are typically < 1000 lovelace with test protocol parameters + -- (minFeeA=1, minFeeB=0). + surplus <- L.Coin <$> Gen.integral (Range.linear 2_000_000 17_000_000) + let fundingCoin = sendCoin + surplus let ledgerTxIn = Api.toShelleyTxIn txIn fundingTxOut = Exp.obtainCommonConstraints era $ From 7bdd354a1b20cee36dfded135b7d0ad5c35a92dd Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 2 Mar 2026 12:03:44 -0400 Subject: [PATCH 04/12] Add change address to calcMinFeeRecursive and improve tests Instead of distributing surplus to the first output, accept a change address parameter and append a dedicated change output. This prevents overpaying recipients when the first output is a payment and allows no-output transactions (e.g. minting) to succeed. - Add L.Addr parameter to calcMinFeeRecursive - Rewrite balanceTxOuts to append/update a change output - Move NotEnoughAda check into balanceTxOuts - Remove NoTxOuts error (no longer needed) - Renumber case comments (1-4) after removing the txBalanceCoin guard - Add dummy change output comparison in balance test to show why the recursive fee differs from the simple estimate - Export calcMinFeeRecursive and FeeCalculationError --- cardano-api/src/Cardano/Api/Experimental.hs | 2 +- .../Api/Experimental/Tx/Internal/Fee.hs | 201 ++++++++++--- .../Test/Cardano/Api/Experimental.hs | 271 +++++++++++++++--- 3 files changed, 405 insertions(+), 69 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index 889443e087..67a59e1867 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -25,7 +25,7 @@ module Cardano.Api.Experimental , mkTxCertificates -- ** Transaction fee related - , RecursiveFeeCalculationError (..) + , FeeCalculationError (..) , calcMinFeeRecursive , estimateBalancedTxBody , evaluateTransactionFee 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 971eff69e4..23ed49fe96 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs @@ -13,7 +13,7 @@ {-# LANGUAGE TypeApplications #-} module Cardano.Api.Experimental.Tx.Internal.Fee - ( RecursiveFeeCalculationError (..) + ( FeeCalculationError (..) , TxBodyErrorAutoBalance (..) , TxFeeEstimationError (..) , calculateMinimumUTxO @@ -660,61 +660,192 @@ evaluateTransactionFee evaluateTransactionFee pp (UnsignedTx tx) keywitcount byronwitcount refScriptsSize = L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize -data RecursiveFeeCalculationError +data FeeCalculationError = NotEnoughAda Coin - | NoTxOuts + | NonAdaAssetsUnbalanced L.MultiAsset + | -- | @MinUTxONotMet actual required@: an output does not meet the minimum UTxO requirement. + MinUTxONotMet L.Coin L.Coin + | FeeCalculationDidNotConverge deriving (Show, Eq) -instance Error RecursiveFeeCalculationError where +instance Error FeeCalculationError where prettyError (NotEnoughAda balance) = mconcat [ "The transaction balance is negative: " , pretty balance , "\nThis means that the transaction does not have enough ada to cover the fees. The usual solution is to provide more inputs, or inputs with more ada." ] - prettyError NoTxOuts = - "The transaction has no outputs. At least one output is required to balance the transaction." + prettyError (NonAdaAssetsUnbalanced multiAsset) = + mconcat + [ "Non-ADA assets are unbalanced: " + , pshow multiAsset + , "\nThe transaction inputs and minted values do not match the outputs for one or more native tokens." + ] + prettyError (MinUTxONotMet actual required) = + mconcat + [ "An output does not meet the minimum UTxO requirement." + , "\nActual ADA in output: " <> pretty actual + , "\nMinimum required: " <> pretty required + , "\nThe usual solution is to provide more ADA inputs to cover the minimum UTxO for outputs carrying native tokens." + ] + prettyError FeeCalculationDidNotConverge = + "Fee calculation did not converge after the maximum number of iterations." +-- | Recursively calculate the minimum fee for a transaction and balance it. +-- +-- Starting from the provided transaction, this function iteratively adjusts +-- the fee field and output values until the transaction is fully balanced +-- (i.e. @inputs + mint + withdrawals + refunds = outputs + fee + deposits@ +-- for all value components: ADA and every native token). +-- +-- On each iteration the balance is computed via 'evaluateTransactionBalance' +-- and the minimum fee via @calcMinFeeTx@. The function then proceeds based +-- on the following cases, evaluated in order: +-- +-- * __Case 1 – Negative multi-asset balance__: The outputs demand more of a +-- native token than is available from inputs and minting. This is +-- unrecoverable because fee adjustments only affect ADA — they cannot +-- change the multi-asset balance. Remedy: provide additional inputs +-- containing the deficit tokens, mint the missing amount, or reduce the +-- token quantities in the outputs. +-- Returns 'NonAdaAssetsUnbalanced'. +-- +-- * __Case 2 – Fee converged, balance is zero__: The transaction is fully +-- balanced. Before returning, all outputs are checked against the minimum +-- UTxO requirement ('MinUTxONotMet'). Note: a 'MinUTxONotMet' error at +-- this point typically means that Case 3 distributed surplus multi-assets +-- to an output on a prior iteration but there was not enough ADA surplus +-- to satisfy the increased @coinPerUTxOByte@ requirement for that output. +-- The remedy is to provide additional ADA inputs. +-- +-- * __Case 3 – Fee converged, non-zero balance__: There is surplus or +-- deficit ADA, excess multi-assets (e.g. from minting), or both. A new +-- change output is created at the provided change address with the +-- balance and appended to the end of the existing outputs; if a change +-- output already exists it is updated in place. If the resulting change +-- output would have negative ADA, the transaction is unrecoverable and +-- 'NotEnoughAda' is returned. Otherwise the function recurses, because +-- the changed output may alter the transaction size and therefore the +-- required fee, and must also satisfy the minimum UTxO +-- (@coinPerUTxOByte@) constraint. +-- +-- * __Case 4 – Fee has not converged__: The fee field is set to the newly +-- computed minimum fee and the function recurses. +-- +-- A maximum iteration limit (currently 50) guards against non-termination. +-- In practice convergence occurs within 2–3 iterations. calcMinFeeRecursive :: forall era . IsEra era - => UnsignedTx (LedgerEra era) + => L.Addr + -- ^ Change address. Any surplus value (ADA and/or native tokens) is + -- sent to a new output at this address, appended at the end of the + -- existing outputs. + -> UnsignedTx (LedgerEra era) -> L.UTxO (LedgerEra era) -> L.PParams (LedgerEra era) + -> Set PoolId + -- ^ The set of registered stake pools. Pool registrations for pools + -- already in this set are treated as re-registrations (no deposit + -- required on the produced side). + -> Map StakeCredential L.Coin + -- ^ Deposits for stake credentials being deregistered in this + -- transaction. These are counted as refunds on the consumed side. + -> Map (Ledger.Credential Ledger.DRepRole) L.Coin + -- ^ Deposits for DRep credentials being deregistered in this + -- transaction. These are counted as refunds on the consumed side. -> Int -- ^ Number of extra key hashes for native scripts - -> Either RecursiveFeeCalculationError (UnsignedTx (LedgerEra era)) -calcMinFeeRecursive unSignTx@(UnsignedTx ledgerTx) utxo pparams nExtraWitnesses - | minFee == txBodyFee && L.isZero txBalanceCoin = - -- We have reached the minimum fee but there isn't a guarantee that - -- the inputs/outputs are balanced - return unSignTx - | minFee == txBodyFee && txBalanceCoin > 0 = do - -- We have a surplus balance so we modify the outputs to include it. - balancedOuts <- balanceTxOuts txBalanceValue unSignTx - let updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ Seq.fromList balancedOuts) - in return updatedTx - | txBalanceCoin < 0 = Left $ NotEnoughAda txBalanceCoin - | otherwise = - let newTx = UnsignedTx (ledgerTx & L.bodyTxL . L.feeTxBodyL .~ minFee) - in calcMinFeeRecursive newTx utxo pparams nExtraWitnesses + -> Either FeeCalculationError (UnsignedTx (LedgerEra era)) +calcMinFeeRecursive changeAddr = go maxIterations where - minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo pparams ledgerTx nExtraWitnesses - txBodyFee = ledgerTx ^. L.bodyTxL . L.feeTxBodyL - txBalanceValue = evaluateTransactionBalance pparams mempty mempty mempty utxo unSignTx - txBalanceCoin = L.coin txBalanceValue + maxIterations :: Int + maxIterations = 50 + + go + :: Int + -> UnsignedTx (LedgerEra era) + -> L.UTxO (LedgerEra era) + -> L.PParams (LedgerEra era) + -> Set PoolId + -> Map StakeCredential L.Coin + -> Map (Ledger.Credential Ledger.DRepRole) L.Coin + -> Int + -> Either FeeCalculationError (UnsignedTx (LedgerEra era)) + go 0 _ _ _ _ _ _ _ = Left FeeCalculationDidNotConverge + go n unSignTx@(UnsignedTx ledgerTx) utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses + | multiAssetIsNegative = + -- Case 1 + Left $ NonAdaAssetsUnbalanced (getMultiAssets (useEra @era) txBalanceValue) + | minFee == txBodyFee && L.isZero txBalanceValue = do + -- Case 2 + let outs = toList $ ledgerTx ^. L.bodyTxL . L.outputsTxBodyL + mapM_ (checkOutputMinUTxO pparams) outs + return unSignTx + | minFee == txBodyFee = do + -- Case 3 + balancedOuts <- balanceTxOuts @era changeAddr txBalanceValue unSignTx + let updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ Seq.fromList balancedOuts) + go (n - 1) updatedTx utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses + | otherwise = + -- Case 4 + let newTx = UnsignedTx (ledgerTx & L.bodyTxL . L.feeTxBodyL .~ minFee) + in go (n - 1) newTx utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses + where + minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo pparams ledgerTx nExtraWitnesses + txBodyFee = ledgerTx ^. L.bodyTxL . L.feeTxBodyL + txBalanceValue = evaluateTransactionBalance pparams poolids stakeDelegDeposits drepDelegDeposits utxo unSignTx + txBalanceCoin = L.coin txBalanceValue + multiAssetIsNegative = + obtainCommonConstraints (useEra @era) $ + not (L.pointwise (>=) txBalanceValue (L.inject txBalanceCoin)) + +checkOutputMinUTxO + :: forall era + . IsEra era + => Ledger.PParams (LedgerEra era) + -> L.TxOut (LedgerEra era) + -> Either FeeCalculationError () +checkOutputMinUTxO pp out = + obtainCommonConstraints (useEra @era) $ + let txout = TxOut out + in case checkMinUTxOValue pp txout of + Right () -> Right () + Left (TxOut offending, minRequired) -> + Left $ MinUTxONotMet (offending ^. L.coinTxOutL) minRequired + +getMultiAssets :: Era era -> L.Value (LedgerEra era) -> L.MultiAsset +getMultiAssets era val = case era of + DijkstraEra -> mempty + ConwayEra -> + let L.MaryValue _ ma = val + in ma balanceTxOuts - :: L.Value (LedgerEra era) + :: forall era + . IsEra era + => L.Addr + -> L.Value (LedgerEra era) -> UnsignedTx (LedgerEra era) - -> Either RecursiveFeeCalculationError [L.TxOut (LedgerEra era)] -balanceTxOuts txBalance (UnsignedTx tx) = - let outs = toList $ tx ^. L.bodyTxL . L.outputsTxBodyL - in case List.uncons outs of - Nothing -> Left NoTxOuts - Just (h, rest) -> - let updatedout = h & L.valueTxOutL %~ (<> txBalance) - in Right $ updatedout : rest + -> Either FeeCalculationError [L.TxOut (LedgerEra era)] +balanceTxOuts changeAddr txBalance (UnsignedTx tx) = + obtainCommonConstraints (useEra @era) $ + let outs = toList $ tx ^. L.bodyTxL . L.outputsTxBodyL + in case reverse outs of + lastOut : revInit + | lastOut ^. L.addrTxOutL == changeAddr -> + -- Update existing change output in place + let updatedOut = lastOut & L.valueTxOutL %~ (<> txBalance) + changeCoin = L.coin (updatedOut ^. L.valueTxOutL) + in if changeCoin < 0 + then Left $ NotEnoughAda changeCoin + else Right $ reverse revInit ++ [updatedOut] + _ -> + -- Append a new change output + let changeCoin = L.coin txBalance + in if changeCoin < 0 + then Left $ NotEnoughAda changeCoin + else Right $ outs ++ [L.mkBasicTxOut changeAddr txBalance] -- Essentially we check for the existence of collateral inputs. If they exist we -- create a fictitious collateral return output. Why? Because we need to put dummy values diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index e0a14b0254..ecce28e705 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -28,6 +28,7 @@ import Cardano.Ledger.Babbage.TxBody qualified as L import Cardano.Ledger.Conway qualified as L import Cardano.Ledger.Core qualified as L import Cardano.Ledger.Credential qualified as L +import Cardano.Ledger.Mary.Value qualified as Mary import Cardano.Ledger.Plutus.Data qualified as L import Cardano.Slotting.EpochInfo qualified as Slotting import Cardano.Slotting.Slot qualified as Slotting @@ -35,6 +36,7 @@ import Cardano.Slotting.Time qualified as Slotting import Control.Monad.Identity (Identity) import Data.Bifunctor (first) +import Data.Foldable (toList) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Maybe.Strict (StrictMaybe (..)) @@ -89,6 +91,15 @@ tests = , testProperty "underfunded transaction (outputs exceed inputs) always fails" prop_calcMinFeeRecursive_insufficient_funds + , testProperty + "Case 2: outputs with tokens not in UTxO returns NonAdaAssetsUnbalanced" + prop_calcMinFeeRecursive_non_ada_unbalanced + , testProperty + "Case 3: output with multi-assets below min UTxO returns MinUTxONotMet" + prop_calcMinFeeRecursive_min_utxo_not_met + , testProperty + "Case 4: transaction with no outputs creates change output" + prop_calcMinFeeRecursive_no_tx_outs ] ] @@ -145,22 +156,18 @@ prop_balance_transaction_two_ways = H.propertyOnce $ do (txBodyContent, newTxBodyContent) <- exampleOldAndNewStyleTxBodyContent era txBody <- H.evalEither $ Api.createTransactionBody sbe txBodyContent - -- Simple way (fee calculation) + -- Simple fee estimate (no change output in tx body) -- Old API let oldFees = Api.evaluateTransactionFee sbe exampleProtocolParams txBody 0 1 0 -- NEW API unSignTx = Exp.makeUnsignedTx era newTxBodyContent newFees = Exp.evaluateTransactionFee exampleProtocolParams unSignTx 0 1 0 - -- Recursive calc - dummyTxIn <- - H.evalEither - ( Api.toShelleyTxIn - <$> Api.runParser - Api.parseTxIn - "be6efd42a3d7b9a00d09d77a5d41e55ceaf0bd093a8aa8a893ce70d9caafd978#0" - ) + oldFees H.=== L.Coin 236 + newFees H.=== L.Coin 236 + -- Set up the change address used by both the dummy output and the + -- recursive fee calculation, so the serialized output sizes match. let paymentCredential :: L.PaymentCredential paymentCredential = L.KeyHashObj $ @@ -174,7 +181,36 @@ prop_balance_transaction_two_ways = H.propertyOnce $ do "e37a65ea2f9bcefb645de4312cf13d8ac12ae61cf242a9aa2973c9ee" initialFundedAddress :: L.Addr initialFundedAddress = L.Addr L.Testnet paymentCredential (L.StakeRefBase stakingCredential) - dummyLargeTxOut :: L.BabbageTxOut L.ConwayEra = + + -- Fee estimate with a dummy change output appended to the tx body. + -- This gives a like-for-like comparison with the recursive fee + -- calculation, which appends a change output during balancing. The + -- dummy output uses an arbitrary ADA value — the exact lovelace amount + -- does not affect the serialized size as long as it falls within the + -- same CBOR integer encoding bucket (values up to ~4.3 billion + -- lovelace use the same 5-byte encoding). + let dummyChangeOutput = + Api.TxOut + (Api.fromShelleyAddr sbe initialFundedAddress) + (Api.lovelaceToTxOutValue sbe 1_000_000) + Api.TxOutDatumNone + Script.ReferenceScriptNone + txBodyContentWithChange = + txBodyContent + & Api.setTxOuts (Api.txOuts txBodyContent ++ [dummyChangeOutput]) + txBodyWithChange <- H.evalEither $ Api.createTransactionBody sbe txBodyContentWithChange + let oldFeesWithChange = Api.evaluateTransactionFee sbe exampleProtocolParams txBodyWithChange 0 1 0 + + -- Recursive calc + dummyTxIn <- + H.evalEither + ( Api.toShelleyTxIn + <$> Api.runParser + Api.parseTxIn + "be6efd42a3d7b9a00d09d77a5d41e55ceaf0bd093a8aa8a893ce70d9caafd978#0" + ) + + let dummyLargeTxOut :: L.BabbageTxOut L.ConwayEra = Exp.obtainCommonConstraints era $ L.BabbageTxOut initialFundedAddress @@ -184,20 +220,29 @@ prop_balance_transaction_two_ways = H.propertyOnce $ do dummyUTxO = L.UTxO $ Map.singleton dummyTxIn dummyLargeTxOut Exp.UnsignedTx recFeeTx <- - H.evalEither $ Exp.calcMinFeeRecursive unSignTx dummyUTxO exampleProtocolParams 0 + H.evalEither $ + Exp.calcMinFeeRecursive + initialFundedAddress + unSignTx + dummyUTxO + exampleProtocolParams + mempty + mempty + mempty + 0 let recFee = recFeeTx ^. (L.bodyTxL . L.feeTxBodyL) - H.note_ $ "Fees 1: " <> show oldFees - oldFees H.=== L.Coin 236 - - newFees H.=== L.Coin 236 - - -- Recursive fee calculation appears result in fees that are ~ 20% lower - recFee H.=== L.Coin 193 - - H.assert $ recFee < oldFees - - H.assert $ recFee < newFees + -- The old-API fee with a dummy change output is higher than the + -- recursive fee because the old API's TxOut encoding (via + -- createTransactionBody) includes optional Babbage-era fields (datum, + -- reference script) even when absent, making the serialized output + -- larger. The recursive calculation uses the ledger's mkBasicTxOut + -- which produces a more compact encoding. + H.note_ $ "Old fees (no change output): " <> show oldFees + H.note_ $ "Old fees (with dummy change output): " <> show oldFeesWithChange + H.note_ $ "Recursive fees: " <> show recFee + oldFeesWithChange H.=== L.Coin 302 + recFee H.=== L.Coin 259 -- Balance without ledger context (other that protocol parameters) -- Old api @@ -523,11 +568,13 @@ genFundedSimpleTx -> Gen ( Exp.UnsignedTx (Exp.LedgerEra era) , L.UTxO (Exp.LedgerEra era) + , L.Addr ) genFundedSimpleTx era = do let sbe = convert era txIn <- genTxIn addr <- Api.toShelleyAddr <$> genAddressInEra sbe + changeAddr <- Api.toShelleyAddr <$> genAddressInEra sbe -- CBOR unsigned integer encoding sizes: ≤23 → 1 byte, ≤255 → 2 bytes, -- ≤65535 → 3 bytes, ≤4294967295 → 5 bytes, >4294967295 → 9 bytes. -- Minimum UTxO (~1 ADA = 1_000_000 lovelace) constrains sendCoin to @@ -560,7 +607,7 @@ genFundedSimpleTx era = do & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] & Exp.setTxOuts [sendTxOut] & Exp.setTxFee 0 - return (Exp.makeUnsignedTx era txBodyContent, utxo) + return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) -- | Generates a simple lovelace-only transaction where the single output -- (5-10 ADA) greatly exceeds the UTxO funding (0.5-2 ADA). @@ -570,11 +617,13 @@ genUnderfundedTx -> Gen ( Exp.UnsignedTx (Exp.LedgerEra era) , L.UTxO (Exp.LedgerEra era) + , L.Addr ) genUnderfundedTx era = do let sbe = convert era txIn <- genTxIn addr <- Api.toShelleyAddr <$> genAddressInEra sbe + changeAddr <- Api.toShelleyAddr <$> genAddressInEra sbe fundingCoin <- L.Coin <$> Gen.integral (Range.linear 500_000 2_000_000) sendCoin <- L.Coin <$> Gen.integral (Range.linear 5_000_000 10_000_000) let ledgerTxIn = Api.toShelleyTxIn txIn @@ -592,14 +641,14 @@ genUnderfundedTx era = do & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] & Exp.setTxOuts [sendTxOut] & Exp.setTxFee 0 - return (Exp.makeUnsignedTx era txBodyContent, utxo) + return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) -- | A well-funded transaction (UTxO >> output + fee) always produces a -- successful positive fee calculation. prop_calcMinFeeRecursive_well_funded_succeeds :: Property prop_calcMinFeeRecursive_well_funded_succeeds = H.property $ do - (unsignedTx, utxo) <- H.forAll $ genFundedSimpleTx Exp.ConwayEra - case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of + (unsignedTx, utxo, changeAddr) <- H.forAll $ genFundedSimpleTx Exp.ConwayEra + case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of Left err -> H.annotateShow err >> H.failure Right (Exp.UnsignedTx resultLedgerTx) -> do let resultFee = resultLedgerTx ^. L.bodyTxL . L.feeTxBodyL @@ -610,21 +659,177 @@ prop_calcMinFeeRecursive_well_funded_succeeds = H.property $ do -- fixed point and that any surplus was already distributed to outputs. prop_calcMinFeeRecursive_fee_fixpoint :: Property prop_calcMinFeeRecursive_fee_fixpoint = H.property $ do - (unsignedTx, utxo) <- H.forAll $ genFundedSimpleTx Exp.ConwayEra - case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of - Left _ -> H.success + (unsignedTx, utxo, changeAddr) <- H.forAll $ genFundedSimpleTx Exp.ConwayEra + case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of + Left err -> H.annotateShow err >> H.failure Right resultTx -> do secondResult <- H.evalEither $ - Exp.calcMinFeeRecursive resultTx utxo exampleProtocolParams 0 + Exp.calcMinFeeRecursive changeAddr resultTx utxo exampleProtocolParams mempty mempty mempty 0 resultTx H.=== secondResult -- | When the outputs exceed the UTxO value the function returns -- 'Left (NotEnoughAda _)' with a negative deficit coin. prop_calcMinFeeRecursive_insufficient_funds :: Property prop_calcMinFeeRecursive_insufficient_funds = H.property $ do - (unsignedTx, utxo) <- H.forAll $ genUnderfundedTx Exp.ConwayEra - case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of + (unsignedTx, utxo, changeAddr) <- H.forAll $ genUnderfundedTx Exp.ConwayEra + case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of Left (Exp.NotEnoughAda deficit) -> H.assert $ deficit < L.Coin 0 - Left Exp.NoTxOuts -> H.annotate "Unexpected NoTxOuts error" >> H.failure + Left Exp.NonAdaAssetsUnbalanced{} -> H.annotate "Unexpected NonAdaAssetsUnbalanced error" >> H.failure + Left Exp.MinUTxONotMet{} -> H.annotate "Unexpected MinUTxONotMet error" >> H.failure + Left Exp.FeeCalculationDidNotConverge -> H.annotate "Unexpected FeeCalculationDidNotConverge error" >> H.failure Right _ -> H.failure + +-- | Generates a transaction whose output demands a native token that does +-- not exist in the UTxO (which is ADA-only). This guarantees a negative +-- multi-asset balance, triggering Case 2 ('NonAdaAssetsUnbalanced'). +genNonAdaUnbalancedTx + :: Exp.Era era + -> Gen + ( Exp.UnsignedTx (Exp.LedgerEra era) + , L.UTxO (Exp.LedgerEra era) + , L.Addr + ) +genNonAdaUnbalancedTx era = do + let sbe = convert era + txIn <- genTxIn + addr <- Api.toShelleyAddr <$> genAddressInEra sbe + changeAddr <- Api.toShelleyAddr <$> genAddressInEra sbe + fundingCoin <- L.Coin <$> Gen.integral (Range.linear 5_000_000 20_000_000) + sendCoin <- L.Coin <$> Gen.integral (Range.linear 1_000_000 3_000_000) + tokenQty <- Gen.integral (Range.linear 1 1_000_000) + let ledgerTxIn = Api.toShelleyTxIn txIn + fundingTxOut = + Exp.obtainCommonConstraints era $ + L.mkBasicTxOut addr (L.MaryValue fundingCoin mempty) + utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut + -- Output demands tokens that don't exist in the ADA-only UTxO + policyId = L.PolicyID $ L.ScriptHash "1c14ee8e58fbcbd48dc7367c95a63fd1d937ba989820015db16ac7e5" + sendValue = + L.MaryValue sendCoin $ + L.MultiAsset $ + Map.singleton policyId (Map.singleton (Mary.AssetName "testtoken") tokenQty) + sendTxOut = + Exp.obtainCommonConstraints era $ + Exp.TxOut $ + Exp.obtainCommonConstraints era $ + Ledger.mkBasicTxOut addr sendValue + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxOuts [sendTxOut] + & Exp.setTxFee 0 + return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) + +-- | Generates a two-output transaction where the second output carries native +-- tokens with only 1000 lovelace — well below the minimum UTxO for a +-- token-bearing output. The surplus ADA is distributed to the first +-- output (Case 4), so the second output stays below minimum, triggering +-- Case 3 ('MinUTxONotMet'). +genMinUTxOViolatingTx + :: Exp.Era era + -> Gen + ( Exp.UnsignedTx (Exp.LedgerEra era) + , L.UTxO (Exp.LedgerEra era) + , L.Addr + ) +genMinUTxOViolatingTx era = do + let sbe = convert era + txIn <- genTxIn + addr <- Api.toShelleyAddr <$> genAddressInEra sbe + changeAddr <- Api.toShelleyAddr <$> genAddressInEra sbe + tokenQty <- Gen.integral (Range.linear 1 1_000_000) + let policyId = L.PolicyID $ L.ScriptHash "1c14ee8e58fbcbd48dc7367c95a63fd1d937ba989820015db16ac7e5" + multiAsset = L.MultiAsset $ Map.singleton policyId (Map.singleton (Mary.AssetName "testtoken") tokenQty) + -- UTxO has plenty of ADA and the same tokens + fundingValue = L.MaryValue (L.Coin 5_000_000) multiAsset + ledgerTxIn = Api.toShelleyTxIn txIn + fundingTxOut = + Exp.obtainCommonConstraints era $ + L.mkBasicTxOut addr fundingValue + utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut + -- Output 1: ADA only, will receive surplus via balanceTxOuts + sendTxOut1 = + Exp.obtainCommonConstraints era $ + Exp.TxOut $ + Exp.obtainCommonConstraints era $ + Ledger.mkBasicTxOut addr (L.MaryValue (L.Coin 1_000_000) mempty) + -- Output 2: tokens with tiny ADA (below min UTxO) + sendTxOut2 = + Exp.obtainCommonConstraints era $ + Exp.TxOut $ + Exp.obtainCommonConstraints era $ + Ledger.mkBasicTxOut addr (L.MaryValue (L.Coin 1_000) multiAsset) + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxOuts [sendTxOut1, sendTxOut2] + & Exp.setTxFee 0 + return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) + +-- | Generates a transaction with inputs but no outputs. Once the fee +-- converges (Case 5), the positive surplus triggers Case 4, and +-- 'balanceTxOuts' creates a change output with the surplus. +genNoOutputsTx + :: Exp.Era era + -> Gen + ( Exp.UnsignedTx (Exp.LedgerEra era) + , L.UTxO (Exp.LedgerEra era) + , L.Addr + ) +genNoOutputsTx era = do + let sbe = convert era + txIn <- genTxIn + addr <- Api.toShelleyAddr <$> genAddressInEra sbe + changeAddr <- Api.toShelleyAddr <$> genAddressInEra sbe + fundingCoin <- L.Coin <$> Gen.integral (Range.linear 5_000_000 20_000_000) + let ledgerTxIn = Api.toShelleyTxIn txIn + fundingTxOut = + Exp.obtainCommonConstraints era $ + L.mkBasicTxOut addr (L.MaryValue fundingCoin mempty) + utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxOuts [] -- No outputs! + & Exp.setTxFee 0 + return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) + +-- | When the output demands tokens not present in the ADA-only UTxO, +-- the function returns 'Left (NonAdaAssetsUnbalanced _)'. +prop_calcMinFeeRecursive_non_ada_unbalanced :: Property +prop_calcMinFeeRecursive_non_ada_unbalanced = H.property $ do + (unsignedTx, utxo, changeAddr) <- H.forAll $ genNonAdaUnbalancedTx Exp.ConwayEra + case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of + Left (Exp.NonAdaAssetsUnbalanced _) -> H.success + Left Exp.NotEnoughAda{} -> H.annotate "Unexpected NotEnoughAda" >> H.failure + Left Exp.MinUTxONotMet{} -> H.annotate "Unexpected MinUTxONotMet" >> H.failure + Left Exp.FeeCalculationDidNotConverge -> H.annotate "Unexpected FeeCalculationDidNotConverge" >> H.failure + Right _ -> H.annotate "Expected NonAdaAssetsUnbalanced but got Right" >> H.failure + +-- | When a token-bearing output has less ADA than the minimum UTxO, +-- the function returns 'Left (MinUTxONotMet actual required)' with +-- @actual < required@. +prop_calcMinFeeRecursive_min_utxo_not_met :: Property +prop_calcMinFeeRecursive_min_utxo_not_met = H.property $ do + (unsignedTx, utxo, changeAddr) <- H.forAll $ genMinUTxOViolatingTx Exp.ConwayEra + case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of + Left (Exp.MinUTxONotMet actual required) -> do + H.annotate $ "Actual: " <> show actual <> ", Required: " <> show required + H.assert $ actual < required + Left Exp.NotEnoughAda{} -> H.annotate "Unexpected NotEnoughAda" >> H.failure + Left Exp.NonAdaAssetsUnbalanced{} -> H.annotate "Unexpected NonAdaAssetsUnbalanced" >> H.failure + Left Exp.FeeCalculationDidNotConverge -> H.annotate "Unexpected FeeCalculationDidNotConverge" >> H.failure + Right _ -> H.annotate "Expected MinUTxONotMet but got Right" >> H.failure + +-- | When the transaction has no outputs, the surplus is sent to a new +-- change output at the provided change address. +prop_calcMinFeeRecursive_no_tx_outs :: Property +prop_calcMinFeeRecursive_no_tx_outs = H.property $ do + (unsignedTx, utxo, changeAddr) <- H.forAll $ genNoOutputsTx Exp.ConwayEra + case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of + Left err -> H.annotateShow err >> H.failure + Right (Exp.UnsignedTx resultLedgerTx) -> do + let outs = toList $ resultLedgerTx ^. L.bodyTxL . L.outputsTxBodyL + -- The result should have exactly one output (the change output) + length outs H.=== 1 From 52e5bc84630ccea3fb32565ffe045b239dcc450e Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 4 Mar 2026 12:34:09 -0400 Subject: [PATCH 05/12] Use StrictSeq pattern matching in balanceTxOuts instead of toList/reverse --- .../Cardano/Api/Experimental/Tx/Internal/Fee.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) 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 23ed49fe96..47f9ed4b9d 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs @@ -785,7 +785,7 @@ calcMinFeeRecursive changeAddr = go maxIterations | minFee == txBodyFee = do -- Case 3 balancedOuts <- balanceTxOuts @era changeAddr txBalanceValue unSignTx - let updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ Seq.fromList balancedOuts) + let updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ balancedOuts) go (n - 1) updatedTx utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses | otherwise = -- Case 4 @@ -827,25 +827,25 @@ balanceTxOuts => L.Addr -> L.Value (LedgerEra era) -> UnsignedTx (LedgerEra era) - -> Either FeeCalculationError [L.TxOut (LedgerEra era)] + -> Either FeeCalculationError (Seq.StrictSeq (L.TxOut (LedgerEra era))) balanceTxOuts changeAddr txBalance (UnsignedTx tx) = obtainCommonConstraints (useEra @era) $ - let outs = toList $ tx ^. L.bodyTxL . L.outputsTxBodyL - in case reverse outs of - lastOut : revInit + let outs = tx ^. L.bodyTxL . L.outputsTxBodyL + in case outs of + rest Seq.:|> lastOut | lastOut ^. L.addrTxOutL == changeAddr -> -- Update existing change output in place let updatedOut = lastOut & L.valueTxOutL %~ (<> txBalance) changeCoin = L.coin (updatedOut ^. L.valueTxOutL) in if changeCoin < 0 then Left $ NotEnoughAda changeCoin - else Right $ reverse revInit ++ [updatedOut] + else Right $ rest Seq.:|> updatedOut _ -> -- Append a new change output let changeCoin = L.coin txBalance in if changeCoin < 0 then Left $ NotEnoughAda changeCoin - else Right $ outs ++ [L.mkBasicTxOut changeAddr txBalance] + else Right $ outs Seq.:|> L.mkBasicTxOut changeAddr txBalance -- Essentially we check for the existence of collateral inputs. If they exist we -- create a fictitious collateral return output. Why? Because we need to put dummy values From 801ddc050e52c907f95cd31b2bb633b65d62a585 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 4 Mar 2026 12:38:50 -0400 Subject: [PATCH 06/12] Align test case numbering with calcMinFeeRecursive Haddock (Cases 1-4) --- .../Test/Cardano/Api/Experimental.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index ecce28e705..82fe59b177 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -92,13 +92,13 @@ tests = "underfunded transaction (outputs exceed inputs) always fails" prop_calcMinFeeRecursive_insufficient_funds , testProperty - "Case 2: outputs with tokens not in UTxO returns NonAdaAssetsUnbalanced" + "Case 1: outputs with tokens not in UTxO returns NonAdaAssetsUnbalanced" prop_calcMinFeeRecursive_non_ada_unbalanced , testProperty - "Case 3: output with multi-assets below min UTxO returns MinUTxONotMet" + "Case 2: output with multi-assets below min UTxO returns MinUTxONotMet" prop_calcMinFeeRecursive_min_utxo_not_met , testProperty - "Case 4: transaction with no outputs creates change output" + "Case 3: transaction with no outputs creates change output" prop_calcMinFeeRecursive_no_tx_outs ] ] @@ -682,7 +682,7 @@ prop_calcMinFeeRecursive_insufficient_funds = H.property $ do -- | Generates a transaction whose output demands a native token that does -- not exist in the UTxO (which is ADA-only). This guarantees a negative --- multi-asset balance, triggering Case 2 ('NonAdaAssetsUnbalanced'). +-- multi-asset balance, triggering Case 1 ('NonAdaAssetsUnbalanced'). genNonAdaUnbalancedTx :: Exp.Era era -> Gen @@ -724,8 +724,8 @@ genNonAdaUnbalancedTx era = do -- | Generates a two-output transaction where the second output carries native -- tokens with only 1000 lovelace — well below the minimum UTxO for a -- token-bearing output. The surplus ADA is distributed to the first --- output (Case 4), so the second output stays below minimum, triggering --- Case 3 ('MinUTxONotMet'). +-- output (Case 3), so the second output stays below minimum, triggering +-- Case 2 ('MinUTxONotMet'). genMinUTxOViolatingTx :: Exp.Era era -> Gen @@ -768,7 +768,7 @@ genMinUTxOViolatingTx era = do return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) -- | Generates a transaction with inputs but no outputs. Once the fee --- converges (Case 5), the positive surplus triggers Case 4, and +-- converges (Case 4), the positive surplus triggers Case 3, and -- 'balanceTxOuts' creates a change output with the surplus. genNoOutputsTx :: Exp.Era era From 842edd70017432b6641e978cd424e0297a04e73c Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Wed, 4 Mar 2026 21:46:14 +0100 Subject: [PATCH 07/12] Test to expose the `Illegal Value in TxOut` issue --- .../Test/Cardano/Api/Experimental.hs | 76 +++++++++++++++++++ 1 file changed, 76 insertions(+) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index 82fe59b177..b16ddcf391 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -100,6 +100,9 @@ tests = , testProperty "Case 3: transaction with no outputs creates change output" prop_calcMinFeeRecursive_no_tx_outs + , testProperty + "Tiny surplus consumed by fee increase yields NotEnoughAda" + prop_calcMinFeeRecursive_tiny_surplus_not_enough_ada ] ] @@ -833,3 +836,76 @@ prop_calcMinFeeRecursive_no_tx_outs = H.property $ do let outs = toList $ resultLedgerTx ^. L.bodyTxL . L.outputsTxBodyL -- The result should have exactly one output (the change output) length outs H.=== 1 + +-- --------------------------------------------------------------------------- +-- Border case: tiny surplus consumed by fee increase +-- --------------------------------------------------------------------------- + +-- | Generates a transaction where the surplus (funding - output) is barely +-- above the fee for the 1-output transaction, but once a change output is +-- appended (increasing the tx size and therefore the fee), the new higher fee +-- exceeds the surplus, driving the change output balance negative. +-- +-- Concretely, with test protocol parameters: +-- Fee for 1-output tx (F1) ≈ 236 lovelace +-- Fee for 2-output tx (F2) ≈ 259 lovelace +-- Delta = F2 - F1 ≈ 23 +-- A surplus of F1 + 1 to F1 + 15 ensures: +-- 1. After fee convergence at F1, a positive balance triggers Case 3. +-- 2. Adding the change output raises the fee to F2. +-- 3. The change is updated: (surplus - F1) + (F1 - F2) = surplus - F2 < 0. +-- 4. balanceTxOuts returns NotEnoughAda. +genTinySurplusTx + :: Exp.Era era + -> Gen + ( Exp.UnsignedTx (Exp.LedgerEra era) + , L.UTxO (Exp.LedgerEra era) + , L.Addr + ) +genTinySurplusTx era = do + let sbe = convert era + txIn <- genTxIn + addr <- Api.toShelleyAddr <$> genAddressInEra sbe + changeAddr <- Api.toShelleyAddr <$> genAddressInEra sbe + sendCoin <- L.Coin <$> Gen.integral (Range.linear 2_000_000 5_000_000) + -- Tiny margin above F1 but below F2. The exact fee F1 depends on the + -- generated address, but with test protocol params it's around 230–240. + -- A surplus of 240 + small_delta is enough to pass the first fee + -- convergence but not survive the fee increase from adding a change output. + -- We use a narrow range to stay within the F1-to-F2 gap (~23 lovelace). + surplus <- L.Coin <$> Gen.integral (Range.linear 237 250) + let fundingCoin = sendCoin + surplus + let ledgerTxIn = Api.toShelleyTxIn txIn + fundingTxOut = + Exp.obtainCommonConstraints era $ + L.mkBasicTxOut addr (L.MaryValue fundingCoin mempty) + utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut + sendTxOut = + Exp.obtainCommonConstraints era $ + Exp.TxOut $ + Exp.obtainCommonConstraints era $ + Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty) + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxOuts [sendTxOut] + & Exp.setTxFee 0 + return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) + +-- | When the surplus is just barely enough to cover the initial fee but not +-- the higher fee after adding a change output, the change output balance +-- goes negative and the function returns NotEnoughAda. +prop_calcMinFeeRecursive_tiny_surplus_not_enough_ada :: Property +prop_calcMinFeeRecursive_tiny_surplus_not_enough_ada = H.property $ do + (unsignedTx, utxo, changeAddr) <- H.forAll $ genTinySurplusTx Exp.ConwayEra + case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of + Left (Exp.NotEnoughAda deficit) -> do + H.annotate $ "Deficit: " <> show deficit + H.assert $ deficit < L.Coin 0 + Left (Exp.MinUTxONotMet actual required) -> do + -- If surplus - F2 >= 0 (barely), we may land in MinUTxONotMet instead. + -- This is also a valid failure for this border region. + H.annotate $ "Change output ADA: " <> show actual <> ", minUTxO: " <> show required + H.assert $ actual < required + Left err -> H.annotateShow err >> H.failure + Right _ -> H.annotate "Expected NotEnoughAda or MinUTxONotMet but tx balanced successfully" >> H.failure From 7f1d9542167542947cfdabfb9c75f6833fac9627 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 5 Mar 2026 11:52:06 -0400 Subject: [PATCH 08/12] Fix Illegal Value in TxOut exception in balanceTxOuts Check the computed value for negativity before writing it into the TxOut. Previously the lens setter (%~) would trigger the ledger's TxOut invariant check and throw an exception before the changeCoin < 0 guard could run. Now we compute the new value on a plain MaryValue first, check it, and only write it with (.~) if non-negative. Also add HasCallStack to balanceTxOuts for better error diagnostics. --- .../Cardano/Api/Experimental/Tx/Internal/Fee.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) 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 47f9ed4b9d..a3a94fa792 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs @@ -90,7 +90,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 @@ -823,7 +823,8 @@ getMultiAssets era val = case era of balanceTxOuts :: forall era - . IsEra era + . HasCallStack + => IsEra era => L.Addr -> L.Value (LedgerEra era) -> UnsignedTx (LedgerEra era) @@ -834,12 +835,15 @@ balanceTxOuts changeAddr txBalance (UnsignedTx tx) = in case outs of rest Seq.:|> lastOut | lastOut ^. L.addrTxOutL == changeAddr -> - -- Update existing change output in place - let updatedOut = lastOut & L.valueTxOutL %~ (<> txBalance) - changeCoin = L.coin (updatedOut ^. L.valueTxOutL) + -- Update existing change output in place. + -- We compute the new value before writing it into the TxOut, + -- because the ledger's TxOut setter throws an exception on + -- negative values. + let newValue = (lastOut ^. L.valueTxOutL) <> txBalance + changeCoin = L.coin newValue in if changeCoin < 0 then Left $ NotEnoughAda changeCoin - else Right $ rest Seq.:|> updatedOut + else Right $ rest Seq.:|> (lastOut & L.valueTxOutL .~ newValue) _ -> -- Append a new change output let changeCoin = L.coin txBalance From 25b425b7b19c6d7fb14e912bd38c930c1d36adb7 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 5 Mar 2026 14:27:10 -0400 Subject: [PATCH 09/12] Hoist multi-asset balance check out of calcMinFeeRecursive loop --- .../Api/Experimental/Tx/Internal/Fee.hs | 70 +++++++++++-------- 1 file changed, 41 insertions(+), 29 deletions(-) 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 a3a94fa792..7ce8ebf6d5 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs @@ -698,27 +698,24 @@ instance Error FeeCalculationError where -- (i.e. @inputs + mint + withdrawals + refunds = outputs + fee + deposits@ -- for all value components: ADA and every native token). -- +-- Before entering the iterative loop the multi-asset balance is checked. +-- Because fee adjustments only affect ADA, a negative multi-asset balance +-- is unrecoverable and the function returns 'NonAdaAssetsUnbalanced' +-- immediately. +-- -- On each iteration the balance is computed via 'evaluateTransactionBalance' -- and the minimum fee via @calcMinFeeTx@. The function then proceeds based -- on the following cases, evaluated in order: -- --- * __Case 1 – Negative multi-asset balance__: The outputs demand more of a --- native token than is available from inputs and minting. This is --- unrecoverable because fee adjustments only affect ADA — they cannot --- change the multi-asset balance. Remedy: provide additional inputs --- containing the deficit tokens, mint the missing amount, or reduce the --- token quantities in the outputs. --- Returns 'NonAdaAssetsUnbalanced'. --- --- * __Case 2 – Fee converged, balance is zero__: The transaction is fully +-- * __Case 1 – Fee converged, balance is zero__: The transaction is fully -- balanced. Before returning, all outputs are checked against the minimum -- UTxO requirement ('MinUTxONotMet'). Note: a 'MinUTxONotMet' error at --- this point typically means that Case 3 distributed surplus multi-assets +-- this point typically means that Case 2 distributed surplus multi-assets -- to an output on a prior iteration but there was not enough ADA surplus -- to satisfy the increased @coinPerUTxOByte@ requirement for that output. -- The remedy is to provide additional ADA inputs. -- --- * __Case 3 – Fee converged, non-zero balance__: There is surplus or +-- * __Case 2 – Fee converged, non-zero balance__: There is surplus or -- deficit ADA, excess multi-assets (e.g. from minting), or both. A new -- change output is created at the provided change address with the -- balance and appended to the end of the existing outputs; if a change @@ -729,7 +726,7 @@ instance Error FeeCalculationError where -- required fee, and must also satisfy the minimum UTxO -- (@coinPerUTxOByte@) constraint. -- --- * __Case 4 – Fee has not converged__: The fee field is set to the newly +-- * __Case 3 – Fee has not converged__: The fee field is set to the newly -- computed minimum fee and the function recurses. -- -- A maximum iteration limit (currently 50) guards against non-termination. @@ -757,8 +754,29 @@ calcMinFeeRecursive -> Int -- ^ Number of extra key hashes for native scripts -> Either FeeCalculationError (UnsignedTx (LedgerEra era)) -calcMinFeeRecursive changeAddr = go maxIterations +calcMinFeeRecursive changeAddr unsignedTx utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses + -- If multi-assets are non-negative initially, they stay non-negative across + -- iterations (only ADA and fee change), so check once upfront. + | multiAssetIsNegative = + Left $ NonAdaAssetsUnbalanced multiAssets + | otherwise = + go + maxIterations + unsignedTx + utxo + pparams + poolids + stakeDelegDeposits + drepDelegDeposits + nExtraWitnesses where + initialBalance = evaluateTransactionBalance pparams poolids stakeDelegDeposits drepDelegDeposits utxo unsignedTx + multiAssets = getMultiAssets (useEra @era) initialBalance + -- Check whether any native token quantity is negative. + -- ADA is zeroed out so it doesn't influence the check. + multiAssetIsNegative = + obtainCommonConstraints (useEra @era) $ + not (L.pointwise (>=) (L.MaryValue (L.Coin 0) multiAssets) mempty) maxIterations :: Int maxIterations = 50 @@ -773,32 +791,26 @@ calcMinFeeRecursive changeAddr = go maxIterations -> Int -> Either FeeCalculationError (UnsignedTx (LedgerEra era)) go 0 _ _ _ _ _ _ _ = Left FeeCalculationDidNotConverge - go n unSignTx@(UnsignedTx ledgerTx) utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses - | multiAssetIsNegative = - -- Case 1 - Left $ NonAdaAssetsUnbalanced (getMultiAssets (useEra @era) txBalanceValue) + go n unSignTx@(UnsignedTx ledgerTx) utxo' pparams' poolids' stakeDelegDeposits' drepDelegDeposits' nExtraWitnesses' | minFee == txBodyFee && L.isZero txBalanceValue = do - -- Case 2 + -- Case 1 let outs = toList $ ledgerTx ^. L.bodyTxL . L.outputsTxBodyL - mapM_ (checkOutputMinUTxO pparams) outs + mapM_ (checkOutputMinUTxO pparams') outs return unSignTx | minFee == txBodyFee = do - -- Case 3 + -- Case 2 balancedOuts <- balanceTxOuts @era changeAddr txBalanceValue unSignTx let updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ balancedOuts) - go (n - 1) updatedTx utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses + go (n - 1) updatedTx utxo' pparams' poolids' stakeDelegDeposits' drepDelegDeposits' nExtraWitnesses' | otherwise = - -- Case 4 + -- Case 3 let newTx = UnsignedTx (ledgerTx & L.bodyTxL . L.feeTxBodyL .~ minFee) - in go (n - 1) newTx utxo pparams poolids stakeDelegDeposits drepDelegDeposits nExtraWitnesses + in go (n - 1) newTx utxo' pparams' poolids' stakeDelegDeposits' drepDelegDeposits' nExtraWitnesses' where - minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo pparams ledgerTx nExtraWitnesses + minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo' pparams' ledgerTx nExtraWitnesses' txBodyFee = ledgerTx ^. L.bodyTxL . L.feeTxBodyL - txBalanceValue = evaluateTransactionBalance pparams poolids stakeDelegDeposits drepDelegDeposits utxo unSignTx - txBalanceCoin = L.coin txBalanceValue - multiAssetIsNegative = - obtainCommonConstraints (useEra @era) $ - not (L.pointwise (>=) txBalanceValue (L.inject txBalanceCoin)) + txBalanceValue = + evaluateTransactionBalance pparams' poolids' stakeDelegDeposits' drepDelegDeposits' utxo' unSignTx checkOutputMinUTxO :: forall era From 5ab0b5e07f5d24f18b8169cdf1d24e17f58d12db Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 5 Mar 2026 14:27:14 -0400 Subject: [PATCH 10/12] Assert well-funded test result is fully balanced --- .../Test/Cardano/Api/Experimental.hs | 28 +++++++++++++------ 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index b16ddcf391..1e851aeab4 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -92,13 +92,13 @@ tests = "underfunded transaction (outputs exceed inputs) always fails" prop_calcMinFeeRecursive_insufficient_funds , testProperty - "Case 1: outputs with tokens not in UTxO returns NonAdaAssetsUnbalanced" + "Precondition: outputs with tokens not in UTxO returns NonAdaAssetsUnbalanced" prop_calcMinFeeRecursive_non_ada_unbalanced , testProperty - "Case 2: output with multi-assets below min UTxO returns MinUTxONotMet" + "Case 1: output with multi-assets below min UTxO returns MinUTxONotMet" prop_calcMinFeeRecursive_min_utxo_not_met , testProperty - "Case 3: transaction with no outputs creates change output" + "Case 2: transaction with no outputs creates change output" prop_calcMinFeeRecursive_no_tx_outs , testProperty "Tiny surplus consumed by fee increase yields NotEnoughAda" @@ -647,7 +647,7 @@ genUnderfundedTx era = do return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) -- | A well-funded transaction (UTxO >> output + fee) always produces a --- successful positive fee calculation. +-- successful, fully balanced result with a positive fee. prop_calcMinFeeRecursive_well_funded_succeeds :: Property prop_calcMinFeeRecursive_well_funded_succeeds = H.property $ do (unsignedTx, utxo, changeAddr) <- H.forAll $ genFundedSimpleTx Exp.ConwayEra @@ -656,6 +656,16 @@ prop_calcMinFeeRecursive_well_funded_succeeds = H.property $ do Right (Exp.UnsignedTx resultLedgerTx) -> do let resultFee = resultLedgerTx ^. L.bodyTxL . L.feeTxBodyL H.assert $ resultFee > L.Coin 0 + -- The resulting transaction must be fully balanced (zero balance). + let balance = + UnexportedLedger.evalBalanceTxBody + exampleProtocolParams + (const Nothing) + (const Nothing) + (const False) + utxo + (resultLedgerTx ^. L.bodyTxL) + balance H.=== mempty -- | 'calcMinFeeRecursive' is idempotent: applying it to its own result -- yields the same 'UnsignedTx'. This confirms the fee has reached a @@ -685,7 +695,7 @@ prop_calcMinFeeRecursive_insufficient_funds = H.property $ do -- | Generates a transaction whose output demands a native token that does -- not exist in the UTxO (which is ADA-only). This guarantees a negative --- multi-asset balance, triggering Case 1 ('NonAdaAssetsUnbalanced'). +-- multi-asset balance, triggering the multi-asset precondition check ('NonAdaAssetsUnbalanced'). genNonAdaUnbalancedTx :: Exp.Era era -> Gen @@ -727,8 +737,8 @@ genNonAdaUnbalancedTx era = do -- | Generates a two-output transaction where the second output carries native -- tokens with only 1000 lovelace — well below the minimum UTxO for a -- token-bearing output. The surplus ADA is distributed to the first --- output (Case 3), so the second output stays below minimum, triggering --- Case 2 ('MinUTxONotMet'). +-- output (Case 2), so the second output stays below minimum, triggering +-- Case 1 ('MinUTxONotMet'). genMinUTxOViolatingTx :: Exp.Era era -> Gen @@ -771,7 +781,7 @@ genMinUTxOViolatingTx era = do return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) -- | Generates a transaction with inputs but no outputs. Once the fee --- converges (Case 4), the positive surplus triggers Case 3, and +-- converges (Case 3), the positive surplus triggers Case 2, and -- 'balanceTxOuts' creates a change output with the surplus. genNoOutputsTx :: Exp.Era era @@ -851,7 +861,7 @@ prop_calcMinFeeRecursive_no_tx_outs = H.property $ do -- Fee for 2-output tx (F2) ≈ 259 lovelace -- Delta = F2 - F1 ≈ 23 -- A surplus of F1 + 1 to F1 + 15 ensures: --- 1. After fee convergence at F1, a positive balance triggers Case 3. +-- 1. After fee convergence at F1, a positive balance triggers Case 2. -- 2. Adding the change output raises the fee to F2. -- 3. The change is updated: (surplus - F1) + (F1 - F2) = surplus - F2 < 0. -- 4. balanceTxOuts returns NotEnoughAda. From c53efcdaee3857c0a53f7210e3440d796015227a Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 5 Mar 2026 14:34:48 -0400 Subject: [PATCH 11/12] Add well-funded multi-asset property test for calcMinFeeRecursive --- .../Test/Cardano/Api/Experimental.hs | 62 +++++++++++++++++++ 1 file changed, 62 insertions(+) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index 1e851aeab4..e69f5058fb 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -85,6 +85,9 @@ tests = [ testProperty "well-funded transaction always succeeds" prop_calcMinFeeRecursive_well_funded_succeeds + , testProperty + "well-funded multi-asset transaction always succeeds" + prop_calcMinFeeRecursive_well_funded_multi_asset , testProperty "fee calculation is idempotent" prop_calcMinFeeRecursive_fee_fixpoint @@ -612,6 +615,44 @@ genFundedSimpleTx era = do & Exp.setTxFee 0 return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) +-- | Like 'genFundedSimpleTx' but the UTxO and output both carry native tokens. +-- The output sends all tokens; the surplus ADA goes to the change output. +-- This exercises Case 2's multi-asset handling on the success path. +genFundedMultiAssetTx + :: Exp.Era era + -> Gen + ( Exp.UnsignedTx (Exp.LedgerEra era) + , L.UTxO (Exp.LedgerEra era) + , L.Addr + ) +genFundedMultiAssetTx era = do + let sbe = convert era + txIn <- genTxIn + addr <- Api.toShelleyAddr <$> genAddressInEra sbe + changeAddr <- Api.toShelleyAddr <$> genAddressInEra sbe + sendCoin <- L.Coin <$> Gen.integral (Range.linear 2_000_000 5_000_000) + surplus <- L.Coin <$> Gen.integral (Range.linear 2_000_000 17_000_000) + tokenQty <- Gen.integral (Range.linear 1 1_000_000) + let fundingCoin = sendCoin + surplus + policyId = L.PolicyID $ L.ScriptHash "1c14ee8e58fbcbd48dc7367c95a63fd1d937ba989820015db16ac7e5" + multiAsset = L.MultiAsset $ Map.singleton policyId (Map.singleton (Mary.AssetName "testtoken") tokenQty) + ledgerTxIn = Api.toShelleyTxIn txIn + fundingTxOut = + Exp.obtainCommonConstraints era $ + L.mkBasicTxOut addr (L.MaryValue fundingCoin multiAsset) + utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut + sendTxOut = + Exp.obtainCommonConstraints era $ + Exp.TxOut $ + Exp.obtainCommonConstraints era $ + Ledger.mkBasicTxOut addr (L.MaryValue sendCoin multiAsset) + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxOuts [sendTxOut] + & Exp.setTxFee 0 + return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) + -- | Generates a simple lovelace-only transaction where the single output -- (5-10 ADA) greatly exceeds the UTxO funding (0.5-2 ADA). genUnderfundedTx @@ -667,6 +708,27 @@ prop_calcMinFeeRecursive_well_funded_succeeds = H.property $ do (resultLedgerTx ^. L.bodyTxL) balance H.=== mempty +-- | Like 'prop_calcMinFeeRecursive_well_funded_succeeds' but the UTxO and +-- output carry native tokens. Verifies that surplus tokens are correctly +-- distributed to the change output and the result is fully balanced. +prop_calcMinFeeRecursive_well_funded_multi_asset :: Property +prop_calcMinFeeRecursive_well_funded_multi_asset = H.property $ do + (unsignedTx, utxo, changeAddr) <- H.forAll $ genFundedMultiAssetTx Exp.ConwayEra + case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of + Left err -> H.annotateShow err >> H.failure + Right (Exp.UnsignedTx resultLedgerTx) -> do + let resultFee = resultLedgerTx ^. L.bodyTxL . L.feeTxBodyL + H.assert $ resultFee > L.Coin 0 + let balance = + UnexportedLedger.evalBalanceTxBody + exampleProtocolParams + (const Nothing) + (const Nothing) + (const False) + utxo + (resultLedgerTx ^. L.bodyTxL) + balance H.=== mempty + -- | 'calcMinFeeRecursive' is idempotent: applying it to its own result -- yields the same 'UnsignedTx'. This confirms the fee has reached a -- fixed point and that any surplus was already distributed to outputs. From 1b5f63a6d9a83092bfcaa7bfd21dee9f87907141 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 9 Mar 2026 09:41:38 -0400 Subject: [PATCH 12/12] Address PR review: simplify calcMinFeeRecursive and remove redundant constraints MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Remove getMultiAssets helper and inline the MaryValue extraction, since EraCommonConstraints guarantees Value ~ MaryValue for all eras including Dijkstra - Remove unnecessary parameters from go's recursive loop — utxo, pparams, poolids, stakeDelegDeposits, drepDelegDeposits, and nExtraWitnesses are never modified and are already in scope from the enclosing function - Remove redundant obtainCommonConstraints calls in test generators where constraints are already in scope from the outer call --- .../Api/Experimental/Tx/Internal/Fee.hs | 63 ++++++++----------- .../Test/Cardano/Api/Experimental.hs | 44 +++++++------ 2 files changed, 48 insertions(+), 59 deletions(-) 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 7ce8ebf6d5..e731dbc12a 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs @@ -661,7 +661,10 @@ evaluateTransactionFee pp (UnsignedTx tx) keywitcount byronwitcount refScriptsSi L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize data FeeCalculationError - = NotEnoughAda Coin + = -- | Updating an existing change output resulted in negative ADA. + NotEnoughAdaForChangeOutput Coin + | -- | Creating a new change output would require negative ADA. + NotEnoughAdaForNewOutput Coin | NonAdaAssetsUnbalanced L.MultiAsset | -- | @MinUTxONotMet actual required@: an output does not meet the minimum UTxO requirement. MinUTxONotMet L.Coin L.Coin @@ -669,9 +672,15 @@ data FeeCalculationError deriving (Show, Eq) instance Error FeeCalculationError where - prettyError (NotEnoughAda balance) = + prettyError (NotEnoughAdaForChangeOutput balance) = mconcat - [ "The transaction balance is negative: " + [ "Not enough ADA when updating existing change output. Balance: " + , pretty balance + , "\nThis means that the transaction does not have enough ada to cover the fees. The usual solution is to provide more inputs, or inputs with more ada." + ] + prettyError (NotEnoughAdaForNewOutput balance) = + mconcat + [ "Not enough ADA when creating new change output. Balance: " , pretty balance , "\nThis means that the transaction does not have enough ada to cover the fees. The usual solution is to provide more inputs, or inputs with more ada." ] @@ -721,7 +730,7 @@ instance Error FeeCalculationError where -- balance and appended to the end of the existing outputs; if a change -- output already exists it is updated in place. If the resulting change -- output would have negative ADA, the transaction is unrecoverable and --- 'NotEnoughAda' is returned. Otherwise the function recurses, because +-- 'NotEnoughAdaForChangeOutput' or 'NotEnoughAdaForNewOutput' is returned. Otherwise the function recurses, because -- the changed output may alter the transaction size and therefore the -- required fee, and must also satisfy the minimum UTxO -- (@coinPerUTxOByte@) constraint. @@ -760,18 +769,13 @@ calcMinFeeRecursive changeAddr unsignedTx utxo pparams poolids stakeDelegDeposit | multiAssetIsNegative = Left $ NonAdaAssetsUnbalanced multiAssets | otherwise = - go - maxIterations - unsignedTx - utxo - pparams - poolids - stakeDelegDeposits - drepDelegDeposits - nExtraWitnesses + go maxIterations unsignedTx where initialBalance = evaluateTransactionBalance pparams poolids stakeDelegDeposits drepDelegDeposits utxo unsignedTx - multiAssets = getMultiAssets (useEra @era) initialBalance + multiAssets = + obtainCommonConstraints (useEra @era) $ + let L.MaryValue _ ma = initialBalance + in ma -- Check whether any native token quantity is negative. -- ADA is zeroed out so it doesn't influence the check. multiAssetIsNegative = @@ -783,34 +787,28 @@ calcMinFeeRecursive changeAddr unsignedTx utxo pparams poolids stakeDelegDeposit go :: Int -> UnsignedTx (LedgerEra era) - -> L.UTxO (LedgerEra era) - -> L.PParams (LedgerEra era) - -> Set PoolId - -> Map StakeCredential L.Coin - -> Map (Ledger.Credential Ledger.DRepRole) L.Coin - -> Int -> Either FeeCalculationError (UnsignedTx (LedgerEra era)) - go 0 _ _ _ _ _ _ _ = Left FeeCalculationDidNotConverge - go n unSignTx@(UnsignedTx ledgerTx) utxo' pparams' poolids' stakeDelegDeposits' drepDelegDeposits' nExtraWitnesses' + go 0 _ = Left FeeCalculationDidNotConverge + go n unSignTx@(UnsignedTx ledgerTx) | minFee == txBodyFee && L.isZero txBalanceValue = do -- Case 1 let outs = toList $ ledgerTx ^. L.bodyTxL . L.outputsTxBodyL - mapM_ (checkOutputMinUTxO pparams') outs + mapM_ (checkOutputMinUTxO pparams) outs return unSignTx | minFee == txBodyFee = do -- Case 2 balancedOuts <- balanceTxOuts @era changeAddr txBalanceValue unSignTx let updatedTx = UnsignedTx (ledgerTx & L.bodyTxL . L.outputsTxBodyL .~ balancedOuts) - go (n - 1) updatedTx utxo' pparams' poolids' stakeDelegDeposits' drepDelegDeposits' nExtraWitnesses' + go (n - 1) updatedTx | otherwise = -- Case 3 let newTx = UnsignedTx (ledgerTx & L.bodyTxL . L.feeTxBodyL .~ minFee) - in go (n - 1) newTx utxo' pparams' poolids' stakeDelegDeposits' drepDelegDeposits' nExtraWitnesses' + in go (n - 1) newTx where - minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo' pparams' ledgerTx nExtraWitnesses' + minFee = obtainCommonConstraints (useEra @era) $ L.calcMinFeeTx utxo pparams ledgerTx nExtraWitnesses txBodyFee = ledgerTx ^. L.bodyTxL . L.feeTxBodyL txBalanceValue = - evaluateTransactionBalance pparams' poolids' stakeDelegDeposits' drepDelegDeposits' utxo' unSignTx + evaluateTransactionBalance pparams poolids stakeDelegDeposits drepDelegDeposits utxo unSignTx checkOutputMinUTxO :: forall era @@ -826,13 +824,6 @@ checkOutputMinUTxO pp out = Left (TxOut offending, minRequired) -> Left $ MinUTxONotMet (offending ^. L.coinTxOutL) minRequired -getMultiAssets :: Era era -> L.Value (LedgerEra era) -> L.MultiAsset -getMultiAssets era val = case era of - DijkstraEra -> mempty - ConwayEra -> - let L.MaryValue _ ma = val - in ma - balanceTxOuts :: forall era . HasCallStack @@ -854,13 +845,13 @@ balanceTxOuts changeAddr txBalance (UnsignedTx tx) = let newValue = (lastOut ^. L.valueTxOutL) <> txBalance changeCoin = L.coin newValue in if changeCoin < 0 - then Left $ NotEnoughAda changeCoin + then Left $ NotEnoughAdaForChangeOutput changeCoin else Right $ rest Seq.:|> (lastOut & L.valueTxOutL .~ newValue) _ -> -- Append a new change output let changeCoin = L.coin txBalance in if changeCoin < 0 - then Left $ NotEnoughAda changeCoin + then Left $ NotEnoughAdaForNewOutput changeCoin else Right $ outs Seq.:|> L.mkBasicTxOut changeAddr txBalance -- Essentially we check for the existence of collateral inputs. If they exist we diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index e69f5058fb..c27ef2b769 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -104,7 +104,7 @@ tests = "Case 2: transaction with no outputs creates change output" prop_calcMinFeeRecursive_no_tx_outs , testProperty - "Tiny surplus consumed by fee increase yields NotEnoughAda" + "Tiny surplus consumed by fee increase yields NotEnoughAdaForChangeOutput" prop_calcMinFeeRecursive_tiny_surplus_not_enough_ada ] ] @@ -606,8 +606,7 @@ genFundedSimpleTx era = do sendTxOut = Exp.obtainCommonConstraints era $ Exp.TxOut $ - Exp.obtainCommonConstraints era $ - Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty) + Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty) txBodyContent = Exp.defaultTxBodyContent & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] @@ -644,8 +643,7 @@ genFundedMultiAssetTx era = do sendTxOut = Exp.obtainCommonConstraints era $ Exp.TxOut $ - Exp.obtainCommonConstraints era $ - Ledger.mkBasicTxOut addr (L.MaryValue sendCoin multiAsset) + Ledger.mkBasicTxOut addr (L.MaryValue sendCoin multiAsset) txBodyContent = Exp.defaultTxBodyContent & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] @@ -678,8 +676,7 @@ genUnderfundedTx era = do sendTxOut = Exp.obtainCommonConstraints era $ Exp.TxOut $ - Exp.obtainCommonConstraints era $ - Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty) + Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty) txBodyContent = Exp.defaultTxBodyContent & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] @@ -744,15 +741,16 @@ prop_calcMinFeeRecursive_fee_fixpoint = H.property $ do resultTx H.=== secondResult -- | When the outputs exceed the UTxO value the function returns --- 'Left (NotEnoughAda _)' with a negative deficit coin. +-- 'Left (NotEnoughAdaForNewOutput _)' with a negative deficit coin. prop_calcMinFeeRecursive_insufficient_funds :: Property prop_calcMinFeeRecursive_insufficient_funds = H.property $ do (unsignedTx, utxo, changeAddr) <- H.forAll $ genUnderfundedTx Exp.ConwayEra case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of - Left (Exp.NotEnoughAda deficit) -> H.assert $ deficit < L.Coin 0 + Left (Exp.NotEnoughAdaForNewOutput deficit) -> H.assert $ deficit < L.Coin 0 Left Exp.NonAdaAssetsUnbalanced{} -> H.annotate "Unexpected NonAdaAssetsUnbalanced error" >> H.failure Left Exp.MinUTxONotMet{} -> H.annotate "Unexpected MinUTxONotMet error" >> H.failure Left Exp.FeeCalculationDidNotConverge -> H.annotate "Unexpected FeeCalculationDidNotConverge error" >> H.failure + Left err -> H.annotateShow err >> H.failure Right _ -> H.failure -- | Generates a transaction whose output demands a native token that does @@ -787,8 +785,7 @@ genNonAdaUnbalancedTx era = do sendTxOut = Exp.obtainCommonConstraints era $ Exp.TxOut $ - Exp.obtainCommonConstraints era $ - Ledger.mkBasicTxOut addr sendValue + Ledger.mkBasicTxOut addr sendValue txBodyContent = Exp.defaultTxBodyContent & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] @@ -827,14 +824,12 @@ genMinUTxOViolatingTx era = do sendTxOut1 = Exp.obtainCommonConstraints era $ Exp.TxOut $ - Exp.obtainCommonConstraints era $ - Ledger.mkBasicTxOut addr (L.MaryValue (L.Coin 1_000_000) mempty) + Ledger.mkBasicTxOut addr (L.MaryValue (L.Coin 1_000_000) mempty) -- Output 2: tokens with tiny ADA (below min UTxO) sendTxOut2 = Exp.obtainCommonConstraints era $ Exp.TxOut $ - Exp.obtainCommonConstraints era $ - Ledger.mkBasicTxOut addr (L.MaryValue (L.Coin 1_000) multiAsset) + Ledger.mkBasicTxOut addr (L.MaryValue (L.Coin 1_000) multiAsset) txBodyContent = Exp.defaultTxBodyContent & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] @@ -877,7 +872,8 @@ prop_calcMinFeeRecursive_non_ada_unbalanced = H.property $ do (unsignedTx, utxo, changeAddr) <- H.forAll $ genNonAdaUnbalancedTx Exp.ConwayEra case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of Left (Exp.NonAdaAssetsUnbalanced _) -> H.success - Left Exp.NotEnoughAda{} -> H.annotate "Unexpected NotEnoughAda" >> H.failure + Left Exp.NotEnoughAdaForChangeOutput{} -> H.annotate "Unexpected NotEnoughAdaForChangeOutput" >> H.failure + Left Exp.NotEnoughAdaForNewOutput{} -> H.annotate "Unexpected NotEnoughAdaForNewOutput" >> H.failure Left Exp.MinUTxONotMet{} -> H.annotate "Unexpected MinUTxONotMet" >> H.failure Left Exp.FeeCalculationDidNotConverge -> H.annotate "Unexpected FeeCalculationDidNotConverge" >> H.failure Right _ -> H.annotate "Expected NonAdaAssetsUnbalanced but got Right" >> H.failure @@ -892,7 +888,8 @@ prop_calcMinFeeRecursive_min_utxo_not_met = H.property $ do Left (Exp.MinUTxONotMet actual required) -> do H.annotate $ "Actual: " <> show actual <> ", Required: " <> show required H.assert $ actual < required - Left Exp.NotEnoughAda{} -> H.annotate "Unexpected NotEnoughAda" >> H.failure + Left Exp.NotEnoughAdaForChangeOutput{} -> H.annotate "Unexpected NotEnoughAdaForChangeOutput" >> H.failure + Left Exp.NotEnoughAdaForNewOutput{} -> H.annotate "Unexpected NotEnoughAdaForNewOutput" >> H.failure Left Exp.NonAdaAssetsUnbalanced{} -> H.annotate "Unexpected NonAdaAssetsUnbalanced" >> H.failure Left Exp.FeeCalculationDidNotConverge -> H.annotate "Unexpected FeeCalculationDidNotConverge" >> H.failure Right _ -> H.annotate "Expected MinUTxONotMet but got Right" >> H.failure @@ -926,7 +923,7 @@ prop_calcMinFeeRecursive_no_tx_outs = H.property $ do -- 1. After fee convergence at F1, a positive balance triggers Case 2. -- 2. Adding the change output raises the fee to F2. -- 3. The change is updated: (surplus - F1) + (F1 - F2) = surplus - F2 < 0. --- 4. balanceTxOuts returns NotEnoughAda. +-- 4. balanceTxOuts returns NotEnoughAdaForChangeOutput. genTinySurplusTx :: Exp.Era era -> Gen @@ -955,8 +952,7 @@ genTinySurplusTx era = do sendTxOut = Exp.obtainCommonConstraints era $ Exp.TxOut $ - Exp.obtainCommonConstraints era $ - Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty) + Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty) txBodyContent = Exp.defaultTxBodyContent & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] @@ -966,12 +962,12 @@ genTinySurplusTx era = do -- | When the surplus is just barely enough to cover the initial fee but not -- the higher fee after adding a change output, the change output balance --- goes negative and the function returns NotEnoughAda. +-- goes negative and the function returns NotEnoughAdaForChangeOutput. prop_calcMinFeeRecursive_tiny_surplus_not_enough_ada :: Property prop_calcMinFeeRecursive_tiny_surplus_not_enough_ada = H.property $ do (unsignedTx, utxo, changeAddr) <- H.forAll $ genTinySurplusTx Exp.ConwayEra case Exp.calcMinFeeRecursive changeAddr unsignedTx utxo exampleProtocolParams mempty mempty mempty 0 of - Left (Exp.NotEnoughAda deficit) -> do + Left (Exp.NotEnoughAdaForChangeOutput deficit) -> do H.annotate $ "Deficit: " <> show deficit H.assert $ deficit < L.Coin 0 Left (Exp.MinUTxONotMet actual required) -> do @@ -980,4 +976,6 @@ prop_calcMinFeeRecursive_tiny_surplus_not_enough_ada = H.property $ do H.annotate $ "Change output ADA: " <> show actual <> ", minUTxO: " <> show required H.assert $ actual < required Left err -> H.annotateShow err >> H.failure - Right _ -> H.annotate "Expected NotEnoughAda or MinUTxONotMet but tx balanced successfully" >> H.failure + Right _ -> + H.annotate "Expected NotEnoughAdaForChangeOutput or MinUTxONotMet but tx balanced successfully" + >> H.failure