try precise calculation

IntersectMBO · Jan 31, 2025 · 12a4f6d · 12a4f6d
1 parent ff36633
commit 12a4f6d
Show file tree

Hide file tree

Showing 3 changed files with 36 additions and 49 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -1045,41 +1045,21 @@ makeTransactionBodyAutoBalance
       -- 3. update tx with fees
       -- 4. balance the transaction and update tx change output
 
-      -- UTXO inputs, which inclue also non-ada assets
-      let totalValueAtUTxO =
-            fromLedgerValue sbe . calculateIncomingUTxOValue . Map.elems $ unUTxO utxo
-          -- this is a partial change: it does not include deposits, but we need to have non-ada assets in it
-          -- from utxo and inputs
-          partialChange =
-            monoidForEraInEon (toCardanoEra sbe) $ \w ->
-              toLedgerValue w $ calculatePartialChangeValue sbe totalValueAtUTxO txbodycontent
-
-      -- For the purpose of fees and execution units calculation we just need to make a txbody larger than
-      -- strictly necessary. We do not need the right values for the fee or change output. We use
-      -- "big enough" values for the change output and set so that the CBOR encoding size of the tx will
-      -- be big enough to cover the size of the final output and fee. Yes this means this current code will
-      -- only work for final fee of less than around 4000 ada (2^32-1 lovelace) and change output of less
-      -- than around 18 trillion ada  (2^64-1 lovelace). However, since at this point we know how much
-      -- non-Ada change to give we can use the true values for that.
-      let maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1
-      let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1)
-      let changeWithMaxLovelace = partialChange & A.adaAssetL sbe .~ maxLovelaceChange
-      let changeTxOut =
-            forShelleyBasedEraInEon
-              sbe
-              (lovelaceToTxOutValue sbe maxLovelaceChange)
-              (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace)
-
-      -- Tx body used only for evaluating execution units, txout exact values do not matter much here. We also
-      -- use 'maxLovelaceChange' in txout to avoid ending up with negative change accidentally (this could
-      -- happen if there's a big certificate deposit being returned for example).
-      txbody0 <-
+      txbodyForChange <- first TxBodyError $ createTransactionBody sbe txbodycontent
+      let initialChangeTxOut =
+            evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbodyForChange
+
+      -- Tx body used only for evaluating execution units. Because txout exact
+      -- values do not matter much here, we are using an initial change value,
+      -- which is slightly overestimated, because it does not include fee or
+      -- scripts execution costs.
+      txbody <-
         first TxBodyError
           $ createTransactionBody
             sbe
           $ txbodycontent
             & modTxOuts
-              (<> [TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone])
+              (<> [TxOut changeaddr initialChangeTxOut TxOutDatumNone ReferenceScriptNone])
       exUnitsMapWithLogs <-
         first TxBodyErrorValidityInterval $
           evaluateTransactionExecutionUnits
@@ -1088,7 +1068,7 @@ makeTransactionBodyAutoBalance
             history
             lpp
             utxo
-            txbody0
+            txbody
 
       let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs
 
@@ -1102,6 +1082,14 @@ makeTransactionBodyAutoBalance
 
       txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent
 
+      -- Make a txbody that we will use for calculating the fees. For the purpose
+      -- of fees we just need to make a txbody of the right size in bytes. We
+      -- do not need the right values for the fee. We use "big enough" value
+      -- for the it and set so that the CBOR encoding size of the tx will be
+      -- big enough to cover the size of the final output and fee. Yes this
+      -- means this current code will only work for final fee of less than
+      -- around 4000 ada (2^32-1 lovelace).
+      let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1)
       -- Make a txbody that we will use for calculating the fees.
       let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput sbe txbodycontent changeaddr
       txbody1 <-
@@ -1112,7 +1100,7 @@ makeTransactionBodyAutoBalance
               { txFee = TxFeeExplicit sbe maxLovelaceFee
               , txOuts =
                   txOuts txbodycontent
-                    <> [TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone]
+                    <> [TxOut changeaddr initialChangeTxOut TxOutDatumNone ReferenceScriptNone]
               , txReturnCollateral = dummyCollRet
               , txTotalCollateral = dummyTotColl
               }
@@ -1248,15 +1236,10 @@ isNotAda _ = True
 onlyAda :: Value -> Bool
 onlyAda = null . toList . filterValue isNotAda
 
-calculateIncomingUTxOValue
-  :: Monoid (Ledger.Value (ShelleyLedgerEra era))
-  => [TxOut ctx era]
-  -> Ledger.Value (ShelleyLedgerEra era)
-calculateIncomingUTxOValue providedUtxoOuts =
-  mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- providedUtxoOuts]
-
--- Calculation taken from validateInsufficientCollateral: https://github.com/input-output-hk/cardano-ledger/blob/389b266d6226dedf3d2aec7af640b3ca4984c5ea/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs#L335
--- TODO: Bug Jared to expose a function from the ledger that returns total and return collateral.
+-- Calculation taken from validateInsufficientCollateral:
+-- https://github.com/input-output-hk/cardano-ledger/blob/389b266d6226dedf3d2aec7af640b3ca4984c5ea/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs#L335
+-- TODO: Bug Jared to expose a function from the ledger that returns total and
+-- return collateral.
 calcReturnAndTotalCollateral
   :: ()
   => Ledger.AlonzoEraPParams (ShelleyLedgerEra era)
@@ -1325,10 +1308,10 @@ calculatePartialChangeValue
   -> Value
   -> TxBodyContent build era
   -> Value
-calculatePartialChangeValue sbe incoming txbodycontent =
+calculatePartialChangeValue sbe incoming txbodycontent = do
   let outgoing = newUtxoValue
       mintedValue = txMintValueToValue $ txMintValue txbodycontent
-   in mconcat [incoming, mintedValue, negateValue outgoing]
+  mconcat [incoming, mintedValue, negateValue outgoing]
  where
   newUtxoValue =
     mconcat [fromLedgerValue sbe v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- txOuts txbodycontent]

diff --git a/cardano-api/internal/Cardano/Api/IPC.hs b/cardano-api/internal/Cardano/Api/IPC.hs
@@ -174,6 +174,7 @@ data LocalNodeConnectInfo
   , localNodeNetworkId :: NetworkId
   , localNodeSocketPath :: SocketPath
   }
+  deriving Show
 
 -- ----------------------------------------------------------------------------
 -- Actually connect to the node

diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs
@@ -110,7 +110,7 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr
         address
         Nothing
   -- the correct amount with manual balancing of assets
-  335_475 === feeWithTxoutAsset
+  335_299 === feeWithTxoutAsset
 
   -- autobalanced body has assets and ADA in the change txout
   (BalancedTxBody balancedContent _ _ fee) <-
@@ -158,16 +158,19 @@ prop_make_transaction_body_autobalance_when_deregistering_certs = H.propertyOnce
 
   stakeCred <- forAll genStakeCredential
   let certs =
-        [ ConwayCertificate ceo $
-            L.ConwayTxCertDeleg (L.ConwayUnRegCert (toShelleyStakeCredential stakeCred) (L.SJust deregDeposit))
+        [
+          ( ConwayCertificate ceo $
+              L.ConwayTxCertDeleg (L.ConwayUnRegCert (toShelleyStakeCredential stakeCred) (L.SJust deregDeposit))
+          , Nothing
+          )
         ]
 
       content =
         defaultTxBodyContent sbe
           & setTxIns txInputs
           & setTxOuts (mkTxOutput beo address txOutCoin Nothing)
           & setTxProtocolParams (pure $ pure pparams)
-          & setTxCertificates (TxCertificates sbe certs (BuildTxWith []))
+          & setTxCertificates (mkTxCertificates sbe certs)
 
   -- autobalanced body has assets and ADA in the change txout
   (BalancedTxBody _ _ changeOut fee) <-
@@ -190,7 +193,7 @@ prop_make_transaction_body_autobalance_when_deregistering_certs = H.propertyOnce
   H.note_ "Sanity check: inputs == outputs"
   mconcat [deregDeposit, txInputsTotalCoin] === mconcat [txOutCoin, fee, changeCoin]
 
-  176_633 === fee
+  180_901 === fee
 
 prop_make_transaction_body_autobalance_multi_asset_collateral :: Property
 prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $ do
@@ -243,7 +246,7 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $
         address
         Nothing
 
-  335_475 === fee
+  335_299 === fee
   TxReturnCollateral _ (TxOut _ txOutValue _ _) <- H.noteShow $ txReturnCollateral balancedContent
   let assets = [a | a@(AssetId _ _, _) <- toList $ txOutValueToValue txOutValue]
   H.note_ "Check that all assets from UTXO, from the collateral txin, are in the return collateral."