Skip to content

Commit 25e5f83

Browse files
carbolymercarbolymer
authored
Merge pull request #829 from IntersectMBO/mgalazyn/fix/allow-for-zero-change-in-autobalancing
Fix autobalancing when there's no change. Add property test.
2 parents 4ed8ec7 + 45a2127 commit 25e5f83

3 files changed

Lines changed: 215 additions & 29 deletions

File tree

‎cardano-api/src/Cardano/Api/Internal/Fees.hs‎

Lines changed: 23 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -384,7 +384,6 @@ import Cardano.Ledger.Plutus.Language qualified as Plutus
384384
import Cardano.Ledger.Val qualified as L
385385
import Ouroboros.Consensus.HardFork.History qualified as Consensus
386386

387-
import Control.Monad
388387
import Data.Bifunctor (bimap, first, second)
389388
import Data.Bitraversable (bitraverse)
390389
import Data.ByteString.Short (ShortByteString)
@@ -651,8 +650,9 @@ estimateBalancedTxBody
651650
balanceTxOut = TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone
652651

653652
-- Step 6. Check all txouts have the min required UTxO value
654-
forM_ (txOuts txbodycontent1) $
655-
\txout -> first TxFeeEstimationBalanceError $ checkMinUTxOValue sbe pparams txout
653+
first (TxFeeEstimationBalanceError . uncurry TxBodyErrorMinUTxONotMet)
654+
. mapM_ (checkMinUTxOValue sbe pparams)
655+
$ txOuts txbodycontent1
656656

657657
-- check if the balance is positive or negative
658658
-- in one case we can produce change, in the other the inputs are insufficient
@@ -1375,7 +1375,9 @@ makeTransactionBodyAutoBalance
13751375
TxOutDatumNone
13761376
ReferenceScriptNone
13771377

1378-
_ <- balanceCheck sbe pp initialChangeTxOut
1378+
-- Initial change is only used for execution units evaluation, so we don't require minimum UTXO requirement
1379+
-- to be satisfied at this point
1380+
_ <- checkNonNegative sbe pp initialChangeTxOut
13791381

13801382
-- Tx body used only for evaluating execution units. Because txout exact
13811383
-- values do not matter much here, we are using an initial change value,
@@ -1477,7 +1479,9 @@ makeTransactionBodyAutoBalance
14771479
}
14781480
let balance = evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2
14791481
balanceTxOut = TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone
1480-
forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue sbe pp txout
1482+
first (uncurry TxBodyErrorMinUTxONotMet)
1483+
. mapM_ (checkMinUTxOValue sbe pp)
1484+
$ txOuts txbodycontent1
14811485

14821486
-- check if change meets txout criteria, and include if non-zero
14831487
finalTxOuts <- checkAndIncludeChange sbe pp balanceTxOut (txOuts txbodycontent1)
@@ -1523,52 +1527,52 @@ checkAndIncludeChange
15231527
-> TxOut CtxTx era
15241528
-> [TxOut CtxTx era]
15251529
-> Either (TxBodyErrorAutoBalance era) [TxOut CtxTx era]
1526-
checkAndIncludeChange sbe pp change rest = do
1527-
isChangeEmpty <- balanceCheck sbe pp change
1530+
checkAndIncludeChange sbe pp change@(TxOut _ changeValue _ _) rest = do
1531+
isChangeEmpty <- checkNonNegative sbe pp change
15281532
if isChangeEmpty == Empty
15291533
then pure rest
15301534
else do
1535+
let coin = txOutValueToLovelace changeValue
1536+
first ((coin &) . uncurry TxBodyErrorAdaBalanceTooSmall) $
1537+
checkMinUTxOValue sbe pp change
15311538
-- We append change at the end so a client can predict the indexes of the outputs.
1532-
-- Note that if this function will append change with 0 ADA, and non-ada assets in it.
15331539
pure $ rest <> [change]
15341540

15351541
checkMinUTxOValue
15361542
:: ShelleyBasedEra era
15371543
-> Ledger.PParams (ShelleyLedgerEra era)
15381544
-> TxOut CtxTx era
1539-
-> Either (TxBodyErrorAutoBalance era) ()
1545+
-> Either (TxOutInAnyEra, Coin) ()
1546+
-- ^ @Left (offending txout, minimum required utxo)@ or @Right ()@ when txout is ok
15401547
checkMinUTxOValue sbe bpp txout@(TxOut _ v _ _) = do
15411548
let minUTxO = calculateMinimumUTxO sbe bpp txout
15421549
if txOutValueToLovelace v >= minUTxO
15431550
then Right ()
1544-
else Left $ TxBodyErrorMinUTxONotMet (txOutInAnyEra (toCardanoEra sbe) txout) minUTxO
1551+
else Left (txOutInAnyEra (toCardanoEra sbe) txout, minUTxO)
15451552

15461553
data IsEmpty = Empty | NonEmpty
15471554
deriving (Eq, Show)
15481555

1549-
balanceCheck
1556+
checkNonNegative
15501557
:: ShelleyBasedEra era
15511558
-> Ledger.PParams (ShelleyLedgerEra era)
15521559
-> TxOut CtxTx era
15531560
-> Either (TxBodyErrorAutoBalance era) IsEmpty
1554-
balanceCheck sbe bpparams txout@(TxOut _ balance _ _) = do
1561+
-- ^ result of check if txout is empty
1562+
checkNonNegative sbe bpparams txout@(TxOut _ balance _ _) = do
15551563
let outValue@(L.MaryValue coin multiAsset) = toMaryValue $ txOutValueToValue balance
15561564
isPositiveValue = L.pointwise (>) outValue mempty
15571565
if
15581566
| L.isZero outValue -> pure Empty -- empty TxOut - ok, it's removed at the end
1559-
| L.isZero coin -> -- no ADA, just non-ADA assets
1567+
| L.isZero coin ->
1568+
-- no ADA, just non-ADA assets: positive lovelace is required in such case
15601569
Left $
15611570
TxBodyErrorAdaBalanceTooSmall
15621571
(TxOutInAnyEra (toCardanoEra sbe) txout)
15631572
(calculateMinimumUTxO sbe bpparams txout)
15641573
coin
15651574
| not isPositiveValue -> Left $ TxBodyErrorBalanceNegative coin multiAsset
1566-
| otherwise ->
1567-
case checkMinUTxOValue sbe bpparams txout of
1568-
Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) ->
1569-
Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO coin
1570-
Left err -> Left err
1571-
Right _ -> Right NonEmpty
1575+
| otherwise -> pure NonEmpty
15721576

15731577
-- Calculation taken from validateInsufficientCollateral:
15741578
-- https://github.com/input-output-hk/cardano-ledger/blob/389b266d6226dedf3d2aec7af640b3ca4984c5ea/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs#L335

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Test.Cardano.Api.Orphans () where
99

1010
import Cardano.Api.Shelley
1111

12+
import Cardano.Ledger.Alonzo.Core qualified as L
1213
import Cardano.Ledger.Mary.Value qualified as L
1314

1415
import Data.String (IsString (..))
@@ -36,3 +37,5 @@ deriving instance Eq (SigningKey KesKey)
3637
deriving instance Eq (SigningKey VrfKey)
3738

3839
deriving instance IsString L.AssetName
40+
41+
deriving instance IsString (L.KeyHash r)

‎cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs‎

Lines changed: 189 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,9 @@ import Cardano.Slotting.EpochInfo qualified as CS
3535
import Cardano.Slotting.Slot qualified as CS
3636
import Cardano.Slotting.Time qualified as CS
3737

38+
import Control.Monad
3839
import Data.Aeson (eitherDecodeStrict)
40+
import Data.Bifunctor (first)
3941
import Data.ByteString qualified as B
4042
import Data.Default (def)
4143
import Data.Function
@@ -55,9 +57,185 @@ import Hedgehog (MonadTest, Property, forAll, (===))
5557
import Hedgehog qualified as H
5658
import Hedgehog.Extras qualified as H
5759
import Hedgehog.Gen qualified as Gen
60+
import Hedgehog.Range qualified as Range
5861
import Test.Tasty (TestTree, testGroup)
5962
import Test.Tasty.Hedgehog (testProperty)
6063

64+
prop_make_transaction_body_autobalance_invariants :: Property
65+
prop_make_transaction_body_autobalance_invariants = H.property $ do
66+
let ceo = ConwayEraOnwardsConway
67+
sbe = convert ceo
68+
69+
systemStart <- parseSystemStart "2021-09-01T00:00:00Z"
70+
let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000)
71+
72+
pparams <-
73+
LedgerProtocolParameters
74+
<$> H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json"
75+
76+
-- assume a value larger the one from protocol params to account for min utxo scaling with minted assets
77+
let minUtxo = 2_000_000
78+
79+
-- generate utxos with random values
80+
utxos <- fmap (UTxO . fromList) . forAll $ do
81+
Gen.list (Range.constant 1 10) $ do
82+
txIn <- genTxIn
83+
addr <- genAddressInEra sbe
84+
utxoValue <- L.Coin <$> Gen.integral (Range.linear minUtxo 20_000_000)
85+
let mintValue = mempty -- TODO generate and check in invariants
86+
txOut =
87+
TxOut
88+
addr
89+
(TxOutValueShelleyBased sbe $ L.MaryValue utxoValue mintValue)
90+
TxOutDatumNone
91+
ReferenceScriptNone
92+
pure (txIn, txOut)
93+
94+
let utxoSum =
95+
mconcat
96+
[ maryValue
97+
| (_, TxOut _ (TxOutValueShelleyBased _ maryValue) _ _) <- toList utxos
98+
]
99+
H.noteShowPretty_ utxoSum
100+
101+
-- split inputs into min utxo txouts
102+
let nTxOuts = L.unCoin (L.coin utxoSum) `div` minUtxo - 1 -- leave one out for change
103+
H.noteShow_ nTxOuts
104+
txOut <- forAll $ forM ([1 .. nTxOuts] :: [Integer]) $ \_ -> do
105+
addr <- genAddressInEra sbe
106+
let mintValue = mempty -- TODO generate and check in invariants
107+
pure $
108+
TxOut
109+
addr
110+
(TxOutValueShelleyBased sbe $ L.MaryValue (L.Coin minUtxo) mintValue)
111+
TxOutDatumNone
112+
ReferenceScriptNone
113+
114+
changeAddress <- forAll $ genAddressInEra sbe
115+
116+
-- use all UTXOs as inputs
117+
let txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos
118+
119+
let content =
120+
defaultTxBodyContent sbe
121+
& setTxIns txInputs
122+
& setTxOuts txOut
123+
& setTxProtocolParams (pure $ pure pparams)
124+
125+
(BalancedTxBody balancedContent _ change fee) <-
126+
H.leftFail . first prettyError $
127+
makeTransactionBodyAutoBalance
128+
sbe
129+
systemStart
130+
epochInfo
131+
pparams
132+
mempty
133+
mempty
134+
mempty
135+
utxos
136+
content
137+
changeAddress
138+
Nothing
139+
140+
H.note_ "Check that fee is greater than 0"
141+
H.assertWith (L.unCoin fee) $ (<) 0
142+
143+
H.noteShow_ fee
144+
H.noteShowPretty_ change
145+
H.noteShowPretty_ $ txOuts balancedContent
146+
147+
let txOutSum =
148+
mconcat
149+
[ maryValue
150+
| TxOut _ (TxOutValueShelleyBased _ maryValue) _ _ <- txOuts balancedContent
151+
]
152+
153+
H.note_ "Check that all inputs are spent"
154+
utxoSum === (txOutSum <> inject fee)
155+
156+
prop_make_transaction_body_autobalance_no_change :: Property
157+
prop_make_transaction_body_autobalance_no_change = H.propertyOnce $ do
158+
let ceo = ConwayEraOnwardsConway
159+
sbe = convert ceo
160+
161+
systemStart <- parseSystemStart "2021-09-01T00:00:00Z"
162+
let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000)
163+
164+
pparams <-
165+
LedgerProtocolParameters
166+
<$> H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json"
167+
168+
let expectedFee = 170_077
169+
utxoValue = 5_000_000
170+
171+
let address =
172+
AddressInEra
173+
(ShelleyAddressInEra sbe)
174+
( ShelleyAddress
175+
L.Testnet
176+
(L.KeyHashObj "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137")
177+
L.StakeRefNull
178+
)
179+
let utxos =
180+
UTxO
181+
[
182+
( TxIn
183+
"01f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53"
184+
(TxIx 0)
185+
, TxOut
186+
address
187+
( TxOutValueShelleyBased
188+
sbe
189+
(L.MaryValue utxoValue mempty)
190+
)
191+
TxOutDatumNone
192+
ReferenceScriptNone
193+
)
194+
]
195+
196+
txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos
197+
198+
-- tx out fully spending the txin minus the fee
199+
txOut =
200+
[ TxOut
201+
address
202+
( TxOutValueShelleyBased
203+
sbe
204+
(L.MaryValue (utxoValue - expectedFee) mempty)
205+
)
206+
TxOutDatumNone
207+
ReferenceScriptNone
208+
]
209+
210+
let content =
211+
defaultTxBodyContent sbe
212+
& setTxIns txInputs
213+
& setTxOuts txOut
214+
& setTxProtocolParams (pure $ pure pparams)
215+
216+
(BalancedTxBody balancedContent _ (TxOut _ (TxOutValueShelleyBased _ change) _ _) fee) <-
217+
H.leftFail . first prettyError $
218+
makeTransactionBodyAutoBalance
219+
sbe
220+
systemStart
221+
epochInfo
222+
pparams
223+
mempty
224+
mempty
225+
mempty
226+
utxos
227+
content
228+
address
229+
Nothing
230+
231+
H.noteShowPretty_ change
232+
H.noteShowPretty_ $ txOuts balancedContent
233+
234+
expectedFee === fee
235+
236+
-- check that the txins were fully spent before autobalancing
237+
H.assertWith change L.isZero
238+
61239
-- | Test that the fee is the same when spending minted asset manually or when autobalancing it
62240
prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset :: Property
63241
prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.propertyOnce $ do
@@ -396,8 +574,7 @@ prop_ensure_gov_actions_are_preserved_by_autobalance = H.propertyOnce $ do
396574
, L.pProcReturnAddr =
397575
L.RewardAccount
398576
{ L.raNetwork = L.Testnet
399-
, L.raCredential =
400-
L.KeyHashObj (L.KeyHash{L.unKeyHash = "0b1b872f7953bccfc4245f3282b3363f3d19e9e001a5c41e307363d7"})
577+
, L.raCredential = L.KeyHashObj "0b1b872f7953bccfc4245f3282b3363f3d19e9e001a5c41e307363d7"
401578
}
402579
, L.pProcGovAction = L.InfoAction
403580
, L.pProcAnchor = anchor
@@ -452,9 +629,7 @@ mkSimpleUTxOs sbe =
452629
(ShelleyAddressInEra sbe)
453630
( ShelleyAddress
454631
L.Testnet
455-
( L.KeyHashObj $
456-
L.KeyHash "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137"
457-
)
632+
(L.KeyHashObj "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137")
458633
L.StakeRefNull
459634
)
460635
)
@@ -518,9 +693,7 @@ mkUtxos beo mScriptHash = babbageEraOnwardsConstraints beo $ do
518693
(ShelleyAddressInEra sbe)
519694
( ShelleyAddress
520695
L.Testnet
521-
( L.KeyHashObj $
522-
L.KeyHash "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137"
523-
)
696+
(L.KeyHashObj "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137")
524697
L.StakeRefNull
525698
)
526699
)
@@ -530,7 +703,7 @@ mkUtxos beo mScriptHash = babbageEraOnwardsConstraints beo $ do
530703
(L.Coin 4_000_000)
531704
( L.MultiAsset $
532705
fromList
533-
[(L.PolicyID scriptHash, [(L.AssetName "eeee", 1)]) | scriptHash <- maybeToList mScriptHash]
706+
[(L.PolicyID scriptHash, [("eeee", 1)]) | scriptHash <- maybeToList mScriptHash]
534707
)
535708
)
536709
)
@@ -569,7 +742,7 @@ mkTxOutput beo address coin mScriptHash = babbageEraOnwardsConstraints beo $ do
569742
coin
570743
( L.MultiAsset $
571744
fromList
572-
[(L.PolicyID scriptHash, [(L.AssetName "eeee", 2)]) | scriptHash <- maybeToList mScriptHash]
745+
[(L.PolicyID scriptHash, [("eeee", 2)]) | scriptHash <- maybeToList mScriptHash]
573746
)
574747
)
575748
)
@@ -597,6 +770,12 @@ tests =
597770
testGroup
598771
"Test.Cardano.Api.Typed.TxBody"
599772
[ testProperty
773+
"makeTransactionBodyAutoBalance invariants"
774+
prop_make_transaction_body_autobalance_invariants
775+
, testProperty
776+
"makeTransactionBodyAutoBalance no change"
777+
prop_make_transaction_body_autobalance_no_change
778+
, testProperty
600779
"makeTransactionBodyAutoBalance test correct fees when mutli-asset tx"
601780
prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset
602781
, testProperty

0 commit comments

Comments
 (0)