Fix flaky genTinySurplusTx by computing surplus dynamically

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,

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

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,55 +329,65 @@ 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
        ( Exp.UnsignedTx (Exp.LedgerEra era)
        , 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