Skip to content

Commit f42c341

Browse files
Jimbo4350Jimbo4350
committed
Recursive fee test
1 parent 7f0d7a8 commit f42c341

1 file changed

Lines changed: 164 additions & 1 deletion

File tree

‎cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs‎

Lines changed: 164 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -44,13 +44,14 @@ import Data.Time qualified as Time
4444
import Data.Time.Clock.POSIX qualified as Time
4545
import Lens.Micro
4646

47-
import Test.Gen.Cardano.Api.Typed (genTx)
47+
import Test.Gen.Cardano.Api.Typed (genAddressInEra, genTx, genTxIn)
4848

4949
import Hedgehog (Gen, Property)
5050
import Hedgehog qualified as H
5151
import Hedgehog.Extras qualified as H
5252
import Hedgehog.Gen qualified as Gen
5353
import Hedgehog.Internal.Property qualified as H
54+
import Hedgehog.Range qualified as Range
5455
import Test.Tasty (TestTree, testGroup)
5556
import Test.Tasty.Hedgehog (testProperty)
5657

@@ -77,8 +78,60 @@ tests =
7778
, testProperty
7879
"Roundtrip SerialiseAsRawBytes SignedTx"
7980
prop_roundtrip_serialise_as_raw_bytes_signed_tx
81+
, testGroup
82+
"calcMinFeeRecursive"
83+
[ testProperty
84+
"well-funded transaction always succeeds"
85+
prop_calcMinFeeRecursive_well_funded_succeeds
86+
, testProperty
87+
"successful result always has a positive fee"
88+
prop_calcMinFeeRecursive_positive_fee
89+
, testProperty
90+
"fee calculation is idempotent"
91+
prop_calcMinFeeRecursive_fee_fixpoint
92+
, testProperty
93+
"underfunded transaction (outputs exceed inputs) always fails"
94+
prop_calcMinFeeRecursive_insufficient_funds
95+
]
8096
]
8197

98+
{-
99+
prop_calcRecursiveFee :: Property
100+
prop_calcRecursiveFee = H.property $ do
101+
-- Recursive calc
102+
dummyTxIn <-
103+
H.evalEither
104+
( Api.toShelleyTxIn
105+
<$> Api.runParser
106+
Api.parseTxIn
107+
"be6efd42a3d7b9a00d09d77a5d41e55ceaf0bd093a8aa8a893ce70d9caafd978#0"
108+
)
109+
110+
let paymentCredential :: L.PaymentCredential
111+
paymentCredential =
112+
L.KeyHashObj $
113+
L.KeyHash
114+
"1c14ee8e58fbcbd48dc7367c95a63fd1d937ba989820015db16ac7e5"
115+
116+
stakingCredential :: L.StakeCredential
117+
stakingCredential =
118+
L.KeyHashObj $
119+
L.KeyHash
120+
"e37a65ea2f9bcefb645de4312cf13d8ac12ae61cf242a9aa2973c9ee"
121+
initialFundedAddress :: L.Addr
122+
initialFundedAddress = L.Addr L.Testnet paymentCredential (L.StakeRefBase stakingCredential)
123+
dummyLargeTxOut :: L.BabbageTxOut L.ConwayEra =
124+
Exp.obtainCommonConstraints era $
125+
L.BabbageTxOut
126+
initialFundedAddress
127+
(L.MaryValue (L.Coin 12_000_000) mempty)
128+
L.NoDatum
129+
SNothing
130+
131+
dummyUTxO = L.UTxO $ Map.singleton dummyTxIn dummyLargeTxOut
132+
Exp.UnsignedTx recFeeTx <-
133+
H.evalEither $ Exp.calcMinFeeRecursive unSignTx dummyUTxO exampleProtocolParams 0
134+
-}
82135
prop_created_transaction_with_both_apis_are_the_same :: Property
83136
prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do
84137
let era = Exp.ConwayEra
@@ -494,3 +547,113 @@ prop_roundtrip_serialise_as_raw_bytes_signed_tx = H.withTests (H.TestLimit 20) $
494547
signedTx
495548
(Text.decodeUtf8 . Api.serialiseToRawBytesHex)
496549
(first show . Api.deserialiseFromRawBytesHex . Text.encodeUtf8)
550+
551+
-- ---------------------------------------------------------------------------
552+
-- Property tests for calcMinFeeRecursive
553+
-- ---------------------------------------------------------------------------
554+
555+
-- | Generates a simple lovelace-only transaction with generous UTxO funding.
556+
-- UTxO has 5-20 ADA, the single output has 1-3 ADA, leaving 2-19 ADA of
557+
-- surplus that covers any realistic fee.
558+
genFundedSimpleTx
559+
:: Gen
560+
( Exp.UnsignedTx (Exp.LedgerEra Exp.ConwayEra)
561+
, L.UTxO (Exp.LedgerEra Exp.ConwayEra)
562+
)
563+
genFundedSimpleTx = do
564+
let era = Exp.ConwayEra
565+
sbe = convert era
566+
txIn <- genTxIn
567+
addr <- Api.toShelleyAddr <$> genAddressInEra sbe
568+
fundingCoin <- L.Coin <$> Gen.integral (Range.linear 5_000_000 20_000_000)
569+
sendCoin <- L.Coin <$> Gen.integral (Range.linear 1_000_000 3_000_000)
570+
let ledgerTxIn = Api.toShelleyTxIn txIn
571+
fundingTxOut =
572+
Exp.obtainCommonConstraints era $
573+
L.BabbageTxOut addr (L.MaryValue fundingCoin mempty) L.NoDatum SNothing
574+
utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut
575+
sendTxOut =
576+
Exp.obtainCommonConstraints era $
577+
Exp.TxOut $
578+
Exp.obtainCommonConstraints era $
579+
Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty)
580+
txBodyContent =
581+
Exp.defaultTxBodyContent
582+
& Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)]
583+
& Exp.setTxOuts [sendTxOut]
584+
& Exp.setTxFee 0
585+
return (Exp.makeUnsignedTx era txBodyContent, utxo)
586+
587+
-- | Generates a simple lovelace-only transaction where the single output
588+
-- (5-10 ADA) greatly exceeds the UTxO funding (0.5-2 ADA).
589+
genUnderfundedTx
590+
:: Gen
591+
( Exp.UnsignedTx (Exp.LedgerEra Exp.ConwayEra)
592+
, L.UTxO (Exp.LedgerEra Exp.ConwayEra)
593+
)
594+
genUnderfundedTx = do
595+
let era = Exp.ConwayEra
596+
sbe = convert era
597+
txIn <- genTxIn
598+
addr <- Api.toShelleyAddr <$> genAddressInEra sbe
599+
fundingCoin <- L.Coin <$> Gen.integral (Range.linear 500_000 2_000_000)
600+
sendCoin <- L.Coin <$> Gen.integral (Range.linear 5_000_000 10_000_000)
601+
let ledgerTxIn = Api.toShelleyTxIn txIn
602+
fundingTxOut =
603+
Exp.obtainCommonConstraints era $
604+
L.BabbageTxOut addr (L.MaryValue fundingCoin mempty) L.NoDatum SNothing
605+
utxo = L.UTxO $ Map.singleton ledgerTxIn fundingTxOut
606+
sendTxOut =
607+
Exp.obtainCommonConstraints era $
608+
Exp.TxOut $
609+
Exp.obtainCommonConstraints era $
610+
Ledger.mkBasicTxOut addr (L.MaryValue sendCoin mempty)
611+
txBodyContent =
612+
Exp.defaultTxBodyContent
613+
& Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)]
614+
& Exp.setTxOuts [sendTxOut]
615+
& Exp.setTxFee 0
616+
return (Exp.makeUnsignedTx era txBodyContent, utxo)
617+
618+
-- | A well-funded transaction (UTxO >> output + fee) always produces a
619+
-- successful fee calculation.
620+
prop_calcMinFeeRecursive_well_funded_succeeds :: Property
621+
prop_calcMinFeeRecursive_well_funded_succeeds = H.property $ do
622+
(unsignedTx, utxo) <- H.forAll genFundedSimpleTx
623+
case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of
624+
Left err -> H.annotateShow err >> H.failure
625+
Right _ -> H.success
626+
627+
-- | When 'calcMinFeeRecursive' succeeds the fee stored in the result
628+
-- transaction is strictly positive.
629+
prop_calcMinFeeRecursive_positive_fee :: Property
630+
prop_calcMinFeeRecursive_positive_fee = H.property $ do
631+
(unsignedTx, utxo) <- H.forAll genFundedSimpleTx
632+
case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of
633+
Left _ -> H.success
634+
Right (Exp.UnsignedTx resultLedgerTx) -> do
635+
let resultFee = resultLedgerTx ^. L.bodyTxL . L.feeTxBodyL
636+
H.assert $ resultFee > L.Coin 0
637+
638+
-- | 'calcMinFeeRecursive' is idempotent: applying it to its own result
639+
-- yields the same 'UnsignedTx'. This confirms the fee has reached a
640+
-- fixed point and that any surplus was already distributed to outputs.
641+
prop_calcMinFeeRecursive_fee_fixpoint :: Property
642+
prop_calcMinFeeRecursive_fee_fixpoint = H.property $ do
643+
(unsignedTx, utxo) <- H.forAll genFundedSimpleTx
644+
case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of
645+
Left _ -> H.success
646+
Right resultTx -> do
647+
secondResult <-
648+
H.evalEither $
649+
Exp.calcMinFeeRecursive resultTx utxo exampleProtocolParams 0
650+
resultTx H.=== secondResult
651+
652+
-- | When the outputs exceed the UTxO value the function returns
653+
-- 'Left (NotEnoughAda _)' with a negative deficit coin.
654+
prop_calcMinFeeRecursive_insufficient_funds :: Property
655+
prop_calcMinFeeRecursive_insufficient_funds = H.property $ do
656+
(unsignedTx, utxo) <- H.forAll genUnderfundedTx
657+
case Exp.calcMinFeeRecursive unsignedTx utxo exampleProtocolParams 0 of
658+
Left (Exp.NotEnoughAda deficit) -> H.assert $ deficit < L.Coin 0
659+
Right _ -> H.failure

0 commit comments

Comments
 (0)