Use exbudget for fees

Author: samuelWilliams99

bot-plutus-interface.cabal

@@ -130,6 +130,7 @@ library
     , text                       ^>=1.2.4.0
     , transformers
     , transformers-either
+    , unordered-containers
     , uuid
     , wai
     , warp

src/BotPlutusInterface/Balance.hs

@@ -11,20 +11,26 @@ import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissingCLI, print
 import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
 import BotPlutusInterface.Files qualified as Files
 import BotPlutusInterface.Types (LogLevel (Debug), PABConfig)
+import Cardano.Api (ExecutionUnitPrices (ExecutionUnitPrices))
+import Cardano.Api.ProtocolParameters (ProtocolParameters)
 import Control.Monad (foldM, void, zipWithM)
 import Control.Monad.Freer (Eff, Member)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Either (EitherT, hoistEither, newEitherT, runEitherT)
+import Data.Aeson qualified as Aeson
+import Data.Coerce (coerce)
 import Data.Either.Combinators (rightToMaybe)
+import Data.HashMap.Strict qualified as HashMap
 import Data.Kind (Type)
 import Data.List (partition, (\\))
 import Data.Map (Map)
 import Data.Map qualified as Map
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromJust, fromMaybe, mapMaybe)
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as Text
+import GHC.Real (Ratio ((:%)))
 import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Address (Address (..))
@@ -128,8 +134,10 @@ balanceTxIO pabConf ownPkh unbalancedTx =
       txWithoutFees <-
         hoistEither $ balanceTxStep minUtxos utxoIndex ownPkh $ tx `withFee` 0
 
-      void $ newEitherT $ CardanoCLI.buildTx @w pabConf privKeys txWithoutFees
-      fees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees
+      exBudget <- newEitherT $ CardanoCLI.buildTx @w pabConf privKeys txWithoutFees
+      nonBudgettedFees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees
+      -- TODO: not fromJust here
+      let fees = nonBudgettedFees + getBudgetPrice (fromJust $ getProtocolParamsPrices pabConf.pcProtocolParams) exBudget
 
       lift $ printLog @w Debug $ "Fees: " ++ show fees
 
@@ -140,6 +148,27 @@ balanceTxIO pabConf ownPkh unbalancedTx =
         then pure (balancedTx, minUtxos)
         else loop utxoIndex privKeys minUtxos balancedTx
 
+-- I can't seem to import the accessor for this?
+-- As such, heres a disgusting hack to read the data
+-- Another possibility is converting the Protocol params to Alonzo params, and reading the `Prices` field
+-- (This is probably safer, I should do that)
+getProtocolParamsPrices :: ProtocolParameters -> Maybe ExecutionUnitPrices
+getProtocolParamsPrices params = do
+  (Aeson.Object o) <- pure $ Aeson.toJSON params
+  unitsValue <- HashMap.lookup "executionUnitPrices" o
+  (Aeson.Success units) <- pure $ Aeson.fromJSON unitsValue
+  pure units
+
+getBudgetPrice :: ExecutionUnitPrices -> Ledger.ExBudget -> Integer
+getBudgetPrice (ExecutionUnitPrices cpuPrice memPrice) (Ledger.ExBudget cpuUsed memUsed) =
+  round cpuCost + round memCost
+  where
+    cpuCost = cpuPrice `multRational` (toInteger @Ledger.SatInt $ coerce cpuUsed)
+    memCost = memPrice `multRational` (toInteger @Ledger.SatInt $ coerce memUsed)
+
+multRational :: Rational -> Integer -> Rational
+multRational (num :% denom) s = (s * num) :% denom
+
 withFee :: Tx -> Integer -> Tx
 withFee tx fee = tx {txFee = Ada.lovelaceValueOf fee}
 

test/Spec/BotPlutusInterface/Contract.hs

@@ -476,7 +476,7 @@ sendTokensWithoutName = do
 mintTokens :: Assertion
 mintTokens = do
   let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0
-      txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1200) Nothing
+      txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1_000_000) Nothing
       initState = def & utxos .~ [(txOutRef, txOut)]
       inTxId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txOutRefId txOutRef
 
@@ -526,18 +526,19 @@ mintTokens = do
           |]
         )
       ,
-        ( 6
+        ( 12
         , [text|
           cardano-cli transaction build-raw --alonzo-era
           --tx-in ${inTxId}#0
           --tx-in-collateral ${inTxId}#0
+          --tx-out ${addr1}+610151
           --tx-out ${addr2}+1000 + 5 ${curSymbol'}.74657374546F6B656E
           --mint-script-file ./result-scripts/policy-${curSymbol'}.plutus
           --mint-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json
           --mint-execution-units (387149,1400)
           --mint 5 ${curSymbol'}.74657374546F6B656E
           --required-signer ./signing-keys/signing-key-${pkh1'}.skey
-          --fee 200
+          --fee 388849
           --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw
           |]
         )
@@ -642,7 +643,7 @@ spendToValidator = do
 redeemFromValidator :: Assertion
 redeemFromValidator = do
   let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0
-      txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 100) Nothing
+      txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1_000_000) Nothing
       txOutRef' = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 1
       txOut' = TxOut valAddr (Ada.lovelaceValueOf 1250) (Just datumHash)
       initState = def & utxos .~ [(txOutRef, txOut), (txOutRef', txOut')]
@@ -709,19 +710,20 @@ redeemFromValidator = do
           |]
         )
       ,
-        ( 12
+        ( 14
         , [text|
           cardano-cli transaction build-raw --alonzo-era
+          --tx-in ${inTxId}#0
           --tx-in ${inTxId}#1
           --tx-in-script-file ./result-scripts/validator-${valHash'}.plutus
           --tx-in-datum-file ./result-scripts/datum-${datumHash'}.json
           --tx-in-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json
           --tx-in-execution-units (476468,1700)
           --tx-in-collateral ${inTxId}#0
-          --tx-out ${addr1}+450
+          --tx-out ${addr1}+522182
           --tx-out ${addr2}+500
           --required-signer ./signing-keys/signing-key-${pkh1'}.skey
-          --fee 300
+          --fee 478568
           --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw
           |]
         )