From 43adc16e92ea536f520656cf249cc92c0ace4fce Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 9 Mar 2026 14:32:33 -0400 Subject: [PATCH 1/8] Implement SerialiseAsCBOR for AnyScript era Add HasTypeProxy and SerialiseAsCBOR instances for AnyScript era, enabling CBOR serialisation/deserialisation of both simple and plutus scripts using the ledger's native Script era encoding format. Closes #1088 --- .../src/Cardano/Api/Experimental/AnyScript.hs | 52 ++++++++++++++++++- 1 file changed, 51 insertions(+), 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs index 1c5d924f45..9ae7dc8635 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs @@ -1,12 +1,15 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Cardano.Api.Experimental.AnyScript ( AnyScript (..) + , AsType (..) , deserialiseAnyPlutusScriptOfLanguage , deserialiseAnySimpleScript , hashAnyScript @@ -18,17 +21,64 @@ import Cardano.Api.Experimental.Plutus.Internal.Script hiding (AnyPlutusScript) import Cardano.Api.Experimental.Simple.Script import Cardano.Api.HasTypeProxy import Cardano.Api.Ledger.Internal.Reexport qualified as L +import Cardano.Api.Serialise.Cbor -import Cardano.Binary qualified as CBOR +import Cardano.Ledger.Binary qualified as CBOR import Cardano.Ledger.Core qualified as L import Cardano.Ledger.Plutus.Language qualified as Plutus import Data.ByteString qualified as BS +import Data.Text qualified as Text +import Prettyprinter (pretty) data AnyScript era where AnySimpleScript :: SimpleScript era -> AnyScript era AnyPlutusScript :: Plutus.PlutusLanguage lang => PlutusScriptInEra lang era -> AnyScript era +instance L.Era era => HasTypeProxy (AnyScript era) where + data AsType (AnyScript era) = AsAnyScript + proxyToAsType _ = AsAnyScript + +instance + L.AlonzoEraScript era + => SerialiseAsCBOR (AnyScript era) + where + serialiseToCBOR (AnySimpleScript (SimpleScript ns)) = + L.serialize' (L.eraProtVerHigh @era) (L.fromNativeScript ns :: L.Script era) + serialiseToCBOR (AnyPlutusScript ps) = + L.serialize' (L.eraProtVerHigh @era) (plutusScriptInEraToScript ps) + + deserialiseFromCBOR _ bs = do + script <- decodeScript + case L.getNativeScript script of + Just ns -> Right $ AnySimpleScript (SimpleScript ns) + Nothing -> + case L.toPlutusScript script of + Just ps -> + L.withPlutusScript ps $ \(plutus :: Plutus.Plutus l) -> + case Plutus.decodePlutusRunnable (L.eraProtVerHigh @era) plutus of + Left e -> + Left $ + CBOR.DecoderErrorCustom + ( mconcat + [ "AnyScript PlutusScript (" + , Text.pack (show (Plutus.plutusLanguage plutus)) + , ")" + ] + ) + (Text.pack . show $ pretty e) + Right runnable -> Right $ AnyPlutusScript (PlutusScriptInEra runnable) + Nothing -> + Left $ + CBOR.DecoderErrorCustom + "AnyScript" + "Decoded Script era is neither a NativeScript nor a PlutusScript" + where + decodeScript :: Either CBOR.DecoderError (L.Script era) + decodeScript = do + r <- CBOR.runAnnotator <$> CBOR.decodeFull' (L.eraProtVerHigh @era) bs + return $ r $ CBOR.Full $ BS.fromStrict bs + hashAnyScript :: forall era. IsEra era => AnyScript (LedgerEra era) -> L.ScriptHash hashAnyScript (AnySimpleScript ss) = hashSimpleScript ss From 470653451384626a746be9ea24767b8ca15355ce Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 9 Mar 2026 16:20:37 -0400 Subject: [PATCH 2/8] Add Eq instance for AnyScript era Uses eqT to handle the existential lang in AnyPlutusScript, delegating to the underlying Eq instances on SimpleScript and PlutusScriptInEra. Also adds Typeable lang constraint to the AnyPlutusScript constructor. --- .../src/Cardano/Api/Experimental/AnyScript.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs index 9ae7dc8635..06b3fcfe66 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs @@ -29,16 +29,26 @@ import Cardano.Ledger.Plutus.Language qualified as Plutus import Data.ByteString qualified as BS import Data.Text qualified as Text +import Data.Type.Equality ((:~:) (..)) +import Data.Typeable (Typeable, eqT) import Prettyprinter (pretty) data AnyScript era where AnySimpleScript :: SimpleScript era -> AnyScript era - AnyPlutusScript :: Plutus.PlutusLanguage lang => PlutusScriptInEra lang era -> AnyScript era + AnyPlutusScript :: (Plutus.PlutusLanguage lang, Typeable lang) => PlutusScriptInEra lang era -> AnyScript era instance L.Era era => HasTypeProxy (AnyScript era) where data AsType (AnyScript era) = AsAnyScript proxyToAsType _ = AsAnyScript +instance Eq (AnyScript era) where + AnySimpleScript s1 == AnySimpleScript s2 = s1 == s2 + AnyPlutusScript (ps1 :: PlutusScriptInEra lang1 era) == AnyPlutusScript (ps2 :: PlutusScriptInEra lang2 era) = + case eqT @lang1 @lang2 of + Just Refl -> ps1 == ps2 + Nothing -> False + _ == _ = False + instance L.AlonzoEraScript era => SerialiseAsCBOR (AnyScript era) From 735b4d561b796d995b5077a18e5697bf449cdbbb Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 9 Mar 2026 16:22:09 -0400 Subject: [PATCH 3/8] Add tests for SerialiseAsCBOR AnyScript and generators Adds genAnyScript and genSimpleScriptInEra generators, along with roundtrip and garbage-input property tests for SerialiseAsCBOR AnyScript. --- .../gen/Test/Gen/Cardano/Api/Experimental.hs | 26 +++++++++- .../src/Cardano/Api/Experimental/AnyScript.hs | 3 +- .../Test/Cardano/Api/Experimental.hs | 52 ++++++++++++++++++- 3 files changed, 77 insertions(+), 4 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Experimental.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Experimental.hs index 4e2298838a..361e90a5d0 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Experimental.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Experimental.hs @@ -1,16 +1,19 @@ {-# LANGUAGE DataKinds #-} module Test.Gen.Cardano.Api.Experimental - ( genScriptWitnessedTxCertificates + ( genAnyScript + , genScriptWitnessedTxCertificates , genScriptWitnessedTxIn , genScriptWitnessedTxMintValue , genScriptWitnessedTxProposals , genScriptWitnesssedTxVotingProcedures , genScriptWitnessedTxWithdrawals + , genSimpleScriptInEra ) where import Cardano.Api (TxIn) +import Cardano.Api qualified as Old import Cardano.Api.Experimental import Cardano.Api.Experimental.AnyScriptWitness import Cardano.Api.Experimental.Tx @@ -19,7 +22,13 @@ import Cardano.Api.Ledger qualified as L import Data.Map.Ordered.Strict qualified as OMap import Data.Typeable -import Test.Gen.Cardano.Api.Typed (genExecutionUnits, genHashableScriptData, genTxIn) +import Test.Gen.Cardano.Api.Typed + ( genExecutionUnits + , genHashableScriptData + , genPlutusScriptInEra + , genSimpleScript + , genTxIn + ) import Hedgehog (Gen) import Hedgehog.Gen qualified as Gen @@ -88,6 +97,19 @@ genAnyPlutusScriptWitnessV4 :: Gen (AnyWitness era) genAnyPlutusScriptWitnessV4 = genAnyPlutusScriptWitness L.SPlutusV4 +genSimpleScriptInEra :: Gen (SimpleScript (LedgerEra ConwayEra)) +genSimpleScriptInEra = do + oldSimpleScript <- genSimpleScript + let timelock = Old.toAllegraTimelock oldSimpleScript + return $ SimpleScript timelock + +genAnyScript :: Gen (AnyScript (LedgerEra ConwayEra)) +genAnyScript = + Gen.choice + [ AnySimpleScript <$> genSimpleScriptInEra + , AnyPlutusScript <$> genPlutusScriptInEra + ] + genAnySimpleScriptWitness :: Gen (SimpleScriptOrReferenceInput era) genAnySimpleScriptWitness = SReferenceScript <$> genTxIn diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs index 06b3fcfe66..7e7a1727fd 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs @@ -35,7 +35,8 @@ import Prettyprinter (pretty) data AnyScript era where AnySimpleScript :: SimpleScript era -> AnyScript era - AnyPlutusScript :: (Plutus.PlutusLanguage lang, Typeable lang) => PlutusScriptInEra lang era -> AnyScript era + AnyPlutusScript + :: (Plutus.PlutusLanguage lang, Typeable lang) => PlutusScriptInEra lang era -> AnyScript era instance L.Era era => HasTypeProxy (AnyScript era) where data AsType (AnyScript era) = AsAnyScript 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 32d92109ab..9778fb9559 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 @@ -45,7 +45,8 @@ 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.Experimental (genAnyScript) +import Test.Gen.Cardano.Api.Typed (genAddressInEra, genTx, genTxIn) import Hedgehog (Gen, Property) import Hedgehog qualified as H @@ -78,8 +79,57 @@ tests = , testProperty "Roundtrip SerialiseAsRawBytes SignedTx" prop_roundtrip_serialise_as_raw_bytes_signed_tx + , testGroup + "SerialiseAsCBOR AnyScript" + [ testProperty + "Roundtrip serialiseToCBOR/deserialiseFromCBOR AnyScript" + prop_roundtrip_cbor_any_script + , testProperty + "Deserialising garbage bytes returns Left" + prop_deserialise_garbage_bytes_returns_left + ] + , testGroup + "calcMinFeeRecursive" + [ 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 + , testProperty + "underfunded transaction (outputs exceed inputs) always fails" + prop_calcMinFeeRecursive_insufficient_funds + , testProperty + "Precondition: outputs with tokens not in UTxO returns NonAdaAssetsUnbalanced" + prop_calcMinFeeRecursive_non_ada_unbalanced + , testProperty + "Case 1: output with multi-assets below min UTxO returns MinUTxONotMet" + prop_calcMinFeeRecursive_min_utxo_not_met + , 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 + ] ] +prop_roundtrip_cbor_any_script :: Property +prop_roundtrip_cbor_any_script = H.property $ do + script <- H.forAll genAnyScript + H.tripping script Exp.serialiseToCBOR (Exp.deserialiseFromCBOR Exp.AsAnyScript) + +-- | Deserialising random garbage bytes should always return 'Left'. +prop_deserialise_garbage_bytes_returns_left :: Property +prop_deserialise_garbage_bytes_returns_left = H.property $ do + garbage <- H.forAll $ Gen.bytes (Range.linear 0 128) + case Exp.deserialiseFromCBOR Exp.AsAnyScript garbage of + Left _ -> H.success + Right _ -> H.annotate "Expected deserialisation failure but got Right" >> H.failure + prop_created_transaction_with_both_apis_are_the_same :: Property prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do let era = Exp.ConwayEra From b03c68ebd97a04904a55c5d669efb0b6b809f8df Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Tue, 10 Mar 2026 16:28:59 -0400 Subject: [PATCH 4/8] Export AnyScript from Cardano.Api.Experimental --- cardano-api/src/Cardano/Api/Experimental.hs | 7 +++++++ cardano-api/src/Cardano/Api/Experimental/AnyScript.hs | 4 ++++ .../test/cardano-api-test/Test/Cardano/Api/Experimental.hs | 6 ++++-- .../Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs | 1 - 4 files changed, 15 insertions(+), 3 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index 67a59e1867..badf263eeb 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -50,6 +50,12 @@ module Cardano.Api.Experimental , Witnessable (..) , WitnessableItem (..) + -- ** AnyScript related + , AnyScript (..) + , deserialiseAnyPlutusScriptOfLanguage + , deserialiseAnySimpleScript + , hashAnyScript + -- ** Simple script related , SimpleScript (..) , SimpleScriptOrReferenceInput (..) @@ -98,6 +104,7 @@ module Cardano.Api.Experimental ) where +import Cardano.Api.Experimental.AnyScript import Cardano.Api.Experimental.Certificate import Cardano.Api.Experimental.Era import Cardano.Api.Experimental.Plutus.Internal.IndexedPlutusScriptWitness diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs index 7e7a1727fd..ace5a15f36 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs @@ -42,6 +42,10 @@ instance L.Era era => HasTypeProxy (AnyScript era) where data AsType (AnyScript era) = AsAnyScript proxyToAsType _ = AsAnyScript +instance Show (AnyScript era) where + show (AnySimpleScript ss) = "AnySimpleScript " ++ show ss + show (AnyPlutusScript ps) = "AnyPlutusScript " ++ show ps + instance Eq (AnyScript era) where AnySimpleScript s1 == AnySimpleScript s2 = s1 == s2 AnyPlutusScript (ps1 :: PlutusScriptInEra lang1 era) == AnyPlutusScript (ps2 :: PlutusScriptInEra lang2 era) = 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 9778fb9559..a320505e51 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 @@ -120,13 +120,15 @@ tests = prop_roundtrip_cbor_any_script :: Property prop_roundtrip_cbor_any_script = H.property $ do script <- H.forAll genAnyScript - H.tripping script Exp.serialiseToCBOR (Exp.deserialiseFromCBOR Exp.AsAnyScript) + H.tripping script Api.serialiseToCBOR (Api.deserialiseFromCBOR Exp.AsAnyScript) -- | Deserialising random garbage bytes should always return 'Left'. prop_deserialise_garbage_bytes_returns_left :: Property prop_deserialise_garbage_bytes_returns_left = H.property $ do garbage <- H.forAll $ Gen.bytes (Range.linear 0 128) - case Exp.deserialiseFromCBOR Exp.AsAnyScript garbage of + case Api.deserialiseFromCBOR + (Exp.AsAnyScript :: Exp.AsType (Exp.AnyScript (Exp.LedgerEra Exp.ConwayEra))) + garbage of Left _ -> H.success Right _ -> H.annotate "Expected deserialisation failure but got Right" >> H.failure diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs index 81e253090d..d802f21b90 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs @@ -11,7 +11,6 @@ where import Cardano.Api (AlonzoEraOnwards (..)) import Cardano.Api qualified as Api import Cardano.Api.Experimental -import Cardano.Api.Experimental.AnyScript import Cardano.Api.Experimental.AnyScriptWitness import Cardano.Api.Experimental.Plutus hiding (AnyPlutusScript (..)) import Cardano.Api.Experimental.Tx qualified as Exp From a2c88df70bf13a1a17d743f05f9f8b6ff560490d Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 13 Mar 2026 08:44:05 -0400 Subject: [PATCH 5/8] Rewrite deserialiseFromCBOR using asum with Alternative Maybe Refactors the nested case expression into named helpers (tryNativeScript, tryPlutusScript) combined with asum, making the parse-or-fail logic more readable and composable. --- .../src/Cardano/Api/Experimental/AnyScript.hs | 48 +++++++++---------- 1 file changed, 23 insertions(+), 25 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs index ace5a15f36..a0656f6774 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs @@ -28,10 +28,10 @@ import Cardano.Ledger.Core qualified as L import Cardano.Ledger.Plutus.Language qualified as Plutus import Data.ByteString qualified as BS -import Data.Text qualified as Text +import Data.Either.Combinators (maybeToRight, rightToMaybe) +import Data.Foldable (asum) import Data.Type.Equality ((:~:) (..)) import Data.Typeable (Typeable, eqT) -import Prettyprinter (pretty) data AnyScript era where AnySimpleScript :: SimpleScript era -> AnyScript era @@ -65,35 +65,33 @@ instance deserialiseFromCBOR _ bs = do script <- decodeScript - case L.getNativeScript script of - Just ns -> Right $ AnySimpleScript (SimpleScript ns) - Nothing -> - case L.toPlutusScript script of - Just ps -> - L.withPlutusScript ps $ \(plutus :: Plutus.Plutus l) -> - case Plutus.decodePlutusRunnable (L.eraProtVerHigh @era) plutus of - Left e -> - Left $ - CBOR.DecoderErrorCustom - ( mconcat - [ "AnyScript PlutusScript (" - , Text.pack (show (Plutus.plutusLanguage plutus)) - , ")" - ] - ) - (Text.pack . show $ pretty e) - Right runnable -> Right $ AnyPlutusScript (PlutusScriptInEra runnable) - Nothing -> - Left $ - CBOR.DecoderErrorCustom - "AnyScript" - "Decoded Script era is neither a NativeScript nor a PlutusScript" + maybeToRight noParseError $ + asum + [ tryNativeScript script + , tryPlutusScript script + ] where decodeScript :: Either CBOR.DecoderError (L.Script era) decodeScript = do r <- CBOR.runAnnotator <$> CBOR.decodeFull' (L.eraProtVerHigh @era) bs return $ r $ CBOR.Full $ BS.fromStrict bs + tryNativeScript :: L.Script era -> Maybe (AnyScript era) + tryNativeScript = fmap (AnySimpleScript . SimpleScript) . L.getNativeScript + + tryPlutusScript :: L.Script era -> Maybe (AnyScript era) + tryPlutusScript script = do + ps <- L.toPlutusScript script + L.withPlutusScript ps $ \(plutus :: Plutus.Plutus l) -> + AnyPlutusScript . PlutusScriptInEra + <$> rightToMaybe (Plutus.decodePlutusRunnable (L.eraProtVerHigh @era) plutus) + + noParseError :: CBOR.DecoderError + noParseError = + CBOR.DecoderErrorCustom + "AnyScript" + "Decoded Script era is neither a NativeScript nor a PlutusScript" + hashAnyScript :: forall era. IsEra era => AnyScript (LedgerEra era) -> L.ScriptHash hashAnyScript (AnySimpleScript ss) = hashSimpleScript ss From 7a769683a5cfd2d3cff3ac46fe6701101a46e5bc Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 13 Mar 2026 09:03:06 -0400 Subject: [PATCH 6/8] Remove pointless garbage-bytes deserialisation property --- .../Test/Cardano/Api/Experimental.hs | 12 ------------ 1 file changed, 12 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 a320505e51..33c44ae4b1 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 @@ -84,9 +84,6 @@ tests = [ testProperty "Roundtrip serialiseToCBOR/deserialiseFromCBOR AnyScript" prop_roundtrip_cbor_any_script - , testProperty - "Deserialising garbage bytes returns Left" - prop_deserialise_garbage_bytes_returns_left ] , testGroup "calcMinFeeRecursive" @@ -122,15 +119,6 @@ prop_roundtrip_cbor_any_script = H.property $ do script <- H.forAll genAnyScript H.tripping script Api.serialiseToCBOR (Api.deserialiseFromCBOR Exp.AsAnyScript) --- | Deserialising random garbage bytes should always return 'Left'. -prop_deserialise_garbage_bytes_returns_left :: Property -prop_deserialise_garbage_bytes_returns_left = H.property $ do - garbage <- H.forAll $ Gen.bytes (Range.linear 0 128) - case Api.deserialiseFromCBOR - (Exp.AsAnyScript :: Exp.AsType (Exp.AnyScript (Exp.LedgerEra Exp.ConwayEra))) - garbage of - Left _ -> H.success - Right _ -> H.annotate "Expected deserialisation failure but got Right" >> H.failure prop_created_transaction_with_both_apis_are_the_same :: Property prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do From e6883fd36e71d9c0b4c1afac3ad985413bd72086 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 13 Mar 2026 10:29:53 -0400 Subject: [PATCH 7/8] Restore calcMinFeeRecursive tests lost during rebase conflict resolution --- .../Test/Cardano/Api/Experimental.hs | 424 ++++++++++++++++++ 1 file changed, 424 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 33c44ae4b1..8cbe82292b 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 @@ -29,6 +29,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 @@ -36,6 +37,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 (..)) @@ -53,6 +55,7 @@ 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) @@ -569,3 +572,424 @@ 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. +-- @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 + ( 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 + -- 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 $ + 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) + +-- | 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 $ + 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 + :: forall era + . Exp.Era era + -> 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 + 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) + +-- | A well-funded transaction (UTxO >> output + fee) always produces a +-- 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 + 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 + -- 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 + +-- | 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. +prop_calcMinFeeRecursive_fee_fixpoint :: Property +prop_calcMinFeeRecursive_fee_fixpoint = H.property $ do + (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 changeAddr resultTx utxo exampleProtocolParams mempty mempty mempty 0 + resultTx H.=== secondResult + +-- | When the outputs exceed the UTxO value the function returns +-- '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.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 +-- not exist in the UTxO (which is ADA-only). This guarantees a negative +-- multi-asset balance, triggering the multi-asset precondition check ('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 $ + 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 2), so the second output stays below minimum, triggering +-- Case 1 ('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 $ + 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 $ + 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 3), the positive surplus triggers Case 2, 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.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 + +-- | 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.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 + +-- | 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 + +-- --------------------------------------------------------------------------- +-- 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 From c0b6e6ab38d4abb719b73a076079e230e92bf5ef Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 13 Mar 2026 14:18:43 -0400 Subject: [PATCH 8/8] Fix fourmolu formatting --- .../test/cardano-api-test/Test/Cardano/Api/Experimental.hs | 1 - 1 file changed, 1 deletion(-) 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 8cbe82292b..ca5977c084 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 @@ -122,7 +122,6 @@ prop_roundtrip_cbor_any_script = H.property $ do script <- H.forAll genAnyScript H.tripping script Api.serialiseToCBOR (Api.deserialiseFromCBOR Exp.AsAnyScript) - prop_created_transaction_with_both_apis_are_the_same :: Property prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do let era = Exp.ConwayEra