Skip to content

Commit

Permalink
Fix fee estimation when autobalancing assets
Browse files Browse the repository at this point in the history
  • Loading branch information
@carbolymer
carbolymer committed Aug 29, 2024
1 parent fa26018 commit dc5d4cb
Show file tree
Hide file tree
Showing 6 changed files with 882 additions and 18 deletions.
2 changes: 2 additions & 0 deletions cardano-api/cardano-api.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -318,6 +318,8 @@ test-suite cardano-api-test
cardano-ledger-api ^>=1.9,
cardano-ledger-binary,
cardano-ledger-core:{cardano-ledger-core, testlib} >=1.8,
cardano-ledger-mary,
cardano-ledger-shelley,
cardano-protocol-tpraos,
cardano-slotting,
cborg,
Expand Down
2 changes: 1 addition & 1 deletion cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -246,7 +246,7 @@ genPlutusScript _ =
genScriptDataSchema :: Gen ScriptDataJsonSchema
genScriptDataSchema = Gen.element [ScriptDataJsonNoSchema, ScriptDataJsonDetailedSchema]

genHashableScriptData :: Gen HashableScriptData
genHashableScriptData :: HasCallStack => Gen HashableScriptData
genHashableScriptData = do
sd <- genScriptData
case deserialiseFromCBOR AsHashableScriptData $ serialiseToCBOR sd of
Expand Down
20 changes: 9 additions & 11 deletions cardano-api/internal/Cardano/Api/Fees.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1062,17 +1062,21 @@ makeTransactionBodyAutoBalance
-- 2. figure out the overall min fees
-- 3. update tx with fees
-- 4. balance the transaction and update tx change output

let totalValueAtSpendableUTxO = fromLedgerValue sbe . calculateIncomingUTxOValue . Map.elems $ unUTxO utxo
change =
monoidForEraInEon (toCardanoEra sbe) $ \w ->
toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent

UnsignedTx unsignedTx0 <-
first TxBodyError
$ makeUnsignedTx
availableEra
$ obtainShimConstraints bEraOnwards
$ txbodycontent
{ txOuts =
txOuts txbodycontent
++ [TxOut changeaddr (lovelaceToTxOutValue sbe 0) TxOutDatumNone ReferenceScriptNone]
-- TODO: think about the size of the change output
-- 1,2,4 or 8 bytes?
TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone
: txOuts txbodycontent
}
exUnitsMapWithLogs <-
first TxBodyErrorValidityInterval
Expand Down Expand Up @@ -1109,12 +1113,6 @@ makeTransactionBodyAutoBalance
let maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1
let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1)

let totalValueAtSpendableUTxO = fromLedgerValue sbe $ calculateIncomingUTxOValue $ Map.elems $ unUTxO utxo
let change =
forShelleyBasedEraInEon
sbe
mempty
(\w -> toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent1)
let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange
let changeTxOut =
forShelleyBasedEraInEon
Expand Down Expand Up @@ -1278,7 +1276,7 @@ isNotAda AdaAssetId = False
isNotAda _ = True

onlyAda :: Value -> Bool
onlyAda = null . valueToList . filterValue isNotAda
onlyAda = null . toList . filterValue isNotAda

calculateIncomingUTxOValue
:: Monoid (Ledger.Value (ShelleyLedgerEra era))
Expand Down
200 changes: 194 additions & 6 deletions cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,14 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

{- HLINT ignore "Use list comprehension" -}
{- HLINT ignore "Use camelCase" -}

module Test.Cardano.Api.Typed.TxBody
( tests
Expand All @@ -10,24 +17,34 @@ where

import Cardano.Api
import qualified Cardano.Api.Ledger as L
import Cardano.Api.Shelley (ReferenceScript (..), ShelleyLedgerEra,
refScriptToShelleyScript)
import Cardano.Api.Script
import Cardano.Api.Shelley (Address (..), LedgerProtocolParameters (..), ShelleyLedgerEra)

import qualified Cardano.Ledger.Mary.Value as L
import qualified Cardano.Ledger.Shelley.Scripts as L
import qualified Cardano.Slotting.EpochInfo as CS
import qualified Cardano.Slotting.Slot as CS
import qualified Cardano.Slotting.Time as CS

import qualified Data.ByteString as B
import Data.Function
import qualified Data.Map.Strict as M
import Data.Maybe (isJust)
import qualified Data.Time.Format as DT
import Data.Type.Equality (TestEquality (testEquality))
import GHC.Exts (IsList (..))
import GHC.Exts (IsList (..), IsString (..))
import GHC.Stack

import Test.Gen.Cardano.Api.Typed (genValidTxBody)
import Test.Gen.Cardano.Api.Typed

import Test.Cardano.Api.Typed.Orphans ()

import Hedgehog (MonadTest, Property, (===))
import qualified Hedgehog as H
import qualified Hedgehog.Extras as H
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)

{- HLINT ignore "Use camelCase" -}

-- | Check the txOuts in a TxBodyContent after a ledger roundtrip.
prop_roundtrip_txbodycontent_txouts :: forall era. ShelleyBasedEra era -> Property
prop_roundtrip_txbodycontent_txouts era = H.property $ do
Expand Down Expand Up @@ -107,6 +124,174 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do
getProposalProcedures TxProposalProceduresNone = Nothing
getProposalProcedures txpp@(TxProposalProcedures _ _) = Just . toList $ convProposalProcedures txpp

-- | Test that the fee is the same when spending minted asset manually or when autobalancing it
prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset :: Property
prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.propertyOnce $ do
let sbe = ShelleyBasedEraConway
era = toCardanoEra sbe
aeo <- H.nothingFail $ forEraMaybeEon @AlonzoEraOnwards era

systemStart <-
fmap SystemStart . H.evalIO $
DT.parseTimeM True DT.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" "2021-09-01T00:00:00Z"

let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000)

pparams <-
LedgerProtocolParameters @ConwayEra
<$> H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json"

plutusWitness <- loadPlutusWitness

let scriptHashStr = "e2b715a86bee4f14fef84081217f9e2646893a7d60a38af69e0aa572"
let policyId' = fromString scriptHashStr
let scriptHash = L.ScriptHash $ fromString scriptHashStr
-- one UTXO with an asset - the same we're minting in the transaction
let utxos =
UTxO
[
( TxIn
"01f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53"
(TxIx 0)
, TxOut
( AddressInEra
(ShelleyAddressInEra ShelleyBasedEraConway)
( ShelleyAddress
L.Testnet
( L.KeyHashObj $
L.KeyHash "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137"
)
L.StakeRefNull
)
)
( TxOutValueShelleyBased
ShelleyBasedEraConway
( L.MaryValue
(L.Coin 4_000_000)
(L.MultiAsset [(L.PolicyID scriptHash, [(L.AssetName "eeee", 1)])])
)
)
TxOutDatumNone
ReferenceScriptNone
)
]

txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos
txInputsCollateral = TxInsCollateral aeo $ toList . M.keys . unUTxO $ utxos

let address =
AddressInEra
(ShelleyAddressInEra ShelleyBasedEraConway)
( ShelleyAddress
L.Testnet
(L.ScriptHashObj scriptHash)
L.StakeRefNull
)
let txOutputs doesIncludeAsset =
[ TxOut
address
( TxOutValueShelleyBased
ShelleyBasedEraConway
( L.MaryValue
(L.Coin 2_000_000)
( L.MultiAsset $
if doesIncludeAsset
then [(L.PolicyID scriptHash, [(L.AssetName "eeee", 2)])]
else []
)
)
)
TxOutDatumNone
ReferenceScriptNone
]

let txMint =
TxMintValue
MaryEraOnwardsConway
[(AssetId policyId' "eeee", 1)]
(BuildTxWith [(policyId', plutusWitness)])

-- tx body content without an asset in TxOut
let content =
defaultTxBodyContent sbe
& setTxIns txInputs
& setTxInsCollateral txInputsCollateral
& setTxOuts (txOutputs False) -- include minted asset in txout manually
& setTxMintValue txMint
& setTxProtocolParams (pure $ pure pparams)

-- tx body content with manually added asset to TxOut
let contentWithTxoutAsset = content & setTxOuts (txOutputs True)

-- change txout only with ADA
(BalancedTxBody balancedContentWithTxoutAsset _ _ feeWithTxoutAsset) <-
H.leftFail $
makeTransactionBodyAutoBalance
sbe
systemStart
epochInfo
pparams
mempty
mempty
mempty
utxos
contentWithTxoutAsset
address
Nothing
-- the correct amount with manual balancing of assets
335_729 === feeWithTxoutAsset

-- autobalanced body has assets and ADA in the change txout
(BalancedTxBody balancedContent _ _ fee) <-
H.leftFail $
makeTransactionBodyAutoBalance
sbe
systemStart
epochInfo
pparams
mempty
mempty
mempty
utxos
content
address
Nothing

H.noteShow_ feeWithTxoutAsset
H.noteShow_ fee
H.note_ "There are differences between fees for two autobalanced TxBodyContents. Diff:"
H.diff balancedContentWithTxoutAsset (\_ _ -> feeWithTxoutAsset == fee) balancedContent
feeWithTxoutAsset === fee
where
loadPlutusWitness
:: HasCallStack
=> MonadFail m
=> MonadIO m
=> MonadTest m
=> m (ScriptWitness WitCtxMint ConwayEra)
loadPlutusWitness = do
envelope <-
H.leftFailM $
fmap (deserialiseFromJSON AsTextEnvelope) . H.evalIO $
B.readFile "test/cardano-api-test/files/input/plutus/v3.alwaysTrue.json"
ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3) (PlutusScript PlutusScriptV3 script) <-
H.leftFail $ deserialiseFromTextEnvelopeAnyOf textEnvTypes envelope
pure $
PlutusScriptWitness
PlutusScriptV3InConway
PlutusScriptV3
(PScript script)
NoScriptDatumForMint
(unsafeHashableScriptData (ScriptDataMap []))
(ExecutionUnits 0 0)

textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang]
textEnvTypes =
[ FromSomeType
(AsScript AsPlutusScriptV3)
(ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3))
]

tests :: TestTree
tests =
testGroup
Expand All @@ -118,4 +303,7 @@ tests =
, testProperty
"roundtrip txbodycontent new conway fields"
prop_roundtrip_txbodycontent_conway_fields
, testProperty
"makeTransactionBodyAutoBalance test correct fees when mutli-asset tx"
prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset
]
5 changes: 5 additions & 0 deletions cardano-api/test/cardano-api-test/files/input/plutus/v3.alwaysTrue.json
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
{
"type": "PlutusScriptV3",
"description": "that's a simple script which always returs True - I'm not sure why it's that big though",
"cborHex": "590b2c590b29010100323232323232323232232498c8c8c954ccd5cd19b874800000844c8c8c8c8c8c8c8ca002646464aa666ae68cdc3a4000004226464646464646464646464646464646466666666666646664664664444444444444445001010807c03a01b00c805c02a013008803c01a00b004801c00a00230013574202860026ae8404cc0908c8c8c954ccd5cd19b87480000084600260406ae84006600a6ae84d5d1000844c0b52401035054310035573c0046aae74004dd5000998120009aba1011232323255333573466e1d20000021132328009919192a999ab9a3370e900000108c004c08cd5d0800ccc0848c8c8c954ccd5cd19b874800000846002604e6ae8400422aa666ae68cdc3a40040042265003375a6ae8400a6eb4d5d0800cdd69aba1357440023574400222606a9201035054310035573c0046aae74004dd50009aba135744002113031491035054310035573c0046aae74004dd51aba100398039aba10029919192a999ab9a3370e900000108c0004554ccd5cd19b87480080084600a6eb8d5d080084554ccd5cd19b8748010008460066ae840042260629201035054310035573c0046aae74004dd51aba10019980f3ae357426ae880046ae88004d5d1000889816249035054310035573c0046aae74004dd50009bad3574201e60026ae84038c004c005d69981100b1aba100c33301501975a6ae8402cc8c8c954ccd5cd19b874800000846002646464aa666ae68cdc3a4000004230013302b75a6ae8400660546ae84d5d1000844c0b5241035054310035573c0046aae74004dd51aba10019919192a999ab9a3370e900000108c004cc0add69aba100198151aba13574400211302d4901035054310035573c0046aae74004dd51aba13574400211302a4901035054310035573c0046aae74004dd51aba100a3302275c6ae84024ccc0548c8c8c954ccd5cd19b8748000008460066eb8d5d080084554ccd5cd19b874800800846012603c6ae8400422aa666ae68cdc3a400800423007301d357420021155333573466e1d2006002118009bad35742003301a357426ae8800422aa666ae68cdc3a40100042300b301c357420021155333573466e1d200a002118029bad357420033018357426ae880042260569201035054310035573c0046aae74004dd50008119aba1008330010233574200e6eb8d5d080319980a80c1980a81311919192a999ab9a3370e900000108c0084554ccd5cd19b87480080084600822aa666ae68cdc3a40080042300011302b491035054310035573c0046aae74004dd50009aba1005330220143574200860046ae8400cc008d5d09aba2003301475c602aeb4d5d10009aba2001357440026ae88004d5d10009aba2001357440026ae88004d5d10009aba2001357440026ae88004d5d10009aba20011130174901035054310035573c0046aae74004dd51aba10099aba10089919192a999ab9a3370e900000108c00cdd71aba100108aa999ab9a3370e900100108c024c028d5d0800ccc01c04cd5d09aba200108aa999ab9a3370e900200108c01cc024d5d080084554ccd5cd19b8748018008460026eb4d5d0800cc018d5d09aba200108aa999ab9a3370e900400108c02cc020d5d080084554ccd5cd19b87480280084600a6eb4d5d0800cc010d5d09aba200108980ba481035054310035573c0046aae74004dd51aba135744010232323255333573466e1d200000211328009bad35742005300a3574200332323255333573466e1d200000211328049980600d9aba10029aba1001998063ae357426ae880046ae880044554ccd5cd19b874800800846002660160346ae84006646464aa666ae68cdc3a400000423001375a6ae840066eb4d5d09aba200108980f2481035054310035573c0046aae74004dd51aba1357440021155333573466e1d200400211805999804806bad357420033300b75c6ae84d5d100084554ccd5cd19b87480180084600e660160346ae8400422aa666ae68cdc3a401000422646500d3300d01c357420073301800f3574200533300b00f75a6ae840072646464aa666ae68cdc3a400000423001375a6ae840066eb4d5d09aba20010898102481035054310035573c0046aae74004dd51aba13574400322330180020010d5d10009aba20011155333573466e1d200a002118029980580d1aba10019919192a999ab9a3370e900000108998073ae3574200222603c9201035054310035573c0046aae74004dd51aba1357440021155333573466e1d200c0021180108980da481035054310035573c0046aae74004dd51aba1357440023574400222602e9201035054310035573c0046aae74004dd50009119118011bab00130152233335573e0025000232801c004c018d55ce800cc014d55cf000a60086ae8800c6ae8400a0004646464aa666ae68cdc3a40000042300d3007357420033300575a6ae84d5d100084554ccd5cd19b874800800846026600e6ae840066600aeb4d5d09aba200108a992999ab9a3370e900200188c00cc020d5d08014c004d5d09aba200208aa999ab9a3370e90030018899402cc024d5d0801cc008d5d0800cdd69aba1357440023574400422aa666ae68cdc3a401000623009300835742005375a6ae84d5d100104554ccd5cd19b874802800c4602a60106ae8400822aa666ae68cdc3a401800623011300835742005375a6ae84d5d100104554ccd5cd19b874803800c4600a6eb8d5d08014dd71aba1357440041155333573466e1d2010003118039bae35742005375a6ae84d5d100104554ccd5cd19b874804800c4600260106ae8400a60106ae84d5d100104554ccd5cd19b874805000c4601e60106ae8400822602c9210350543100232323255333573466e1d2000002118009bae35742002115325333573466e1d20020031180298009aba100208aa999ab9a3370e900200188c00cdd71aba100298009aba13574400411301a49010350543100232323255333573466e1d20000021180098079aba100108aa999ab9a3370e900100108c0084554ccd5cd19b87480100084600822603a9201035054310035573c0046aae74004dd50009aab9e00235573a0026ea8004d55cf0011aab9d001375400244646464aa666ae68cdc3a4004004230021155333573466e1d20000021180098029aba100108980aa49035054310035573c0046aae74004dd500091919192a999ab9a3370e900000108c004c014d5d080084554ccd5cd19b874800800846006600a6ae8400422aa666ae68cdc3a400800423005375c6ae840042260269201035054310035573c0046aae74004dd500091919192a999ab9a3370e900000108c004dd71aba100108aa999ab9a3370e900100108c00cdd71aba1001089809249035054310035573c0046aae74004dd500091919192a999ab9a3370e900000108c004dd71aba10019bad357426ae880042260229201035054310035573c0046aae74004dd50009aba200111300c4901035054310035573c0046aae74004dd500098041112a999ab9a3370e9000000889805248103505433001155333573466e200052000113300333702900000119b814800000444ca00266e1000c00666e1000800466008004002600e444aa666ae68cdc3a400000222004226600600266e180080048c88c008dd60009803911999aab9f00128001400cc010d5d08014c00cd5d1001200040024646464aa666ae68cdc3a4000004230021155333573466e1d200200211800089803a481035054310035573c0046aae74004dd5000911919192a999ab9a3370e900000108c0084554ccd5cd19b874800800846002600a6ae8400422aa666ae68cdc3a400800423004113007491035054310035573c0046aae74004dd500091919192a999ab9a3370e900000108c004dd71aba10019bad357426ae8800422600a9201035054310035573c0046aae74004dd5000919319ab9c0018001191800800918011198010010009"
}
Loading

0 comments on commit dc5d4cb

Please sign in to comment.