Merge pull request #74 from mlabs-haskell/bug/fix-calculateExBudget

Add Script context to budget estimation

Author: samuelWilliams99

README.md

@@ -96,6 +96,8 @@ main = do
           , -- Dry run mode will build the tx, but skip the submit step
             pcDryRun = False
           , pcLogLevel = Debug
+          , -- | Forced budget for scripts, as optional (CPU Steps, Memory Units)
+            pcForceBudget = Nothing
           , -- Protocol params file location relative to the cardano-cli working directory (needed for the cli)
           , pcProtocolParamsFile = "./protocol.json"
           , pcEnableTxEndpoint = True

bot-plutus-interface.cabal

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

examples/plutus-game/app/Main.hs

@@ -67,6 +67,7 @@ main = do
           , pcDryRun = True
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
+          , pcForceBudget = Just (1000, 1000)
           , pcEnableTxEndpoint = True
           }
   BotPlutusInterface.runPAB @GameContracts pabConf

examples/plutus-nft/app/Main.hs

@@ -67,6 +67,7 @@ main = do
           , pcDryRun = True
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
+          , pcForceBudget = Just (1000, 1000)
           , pcEnableTxEndpoint = True
           }
   BotPlutusInterface.runPAB @MintNFTContracts pabConf

examples/plutus-transfer/app/Main.hs

@@ -66,6 +66,7 @@ main = do
           , pcDryRun = True
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
+          , pcForceBudget = Nothing
           , pcEnableTxEndpoint = True
           }
   BotPlutusInterface.runPAB @TransferContracts pabConf

src/BotPlutusInterface/Balance.hs

@@ -11,10 +11,13 @@ 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.Shelley (ProtocolParameters (protocolParamPrices))
 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.Coerce (coerce)
 import Data.Either.Combinators (rightToMaybe)
 import Data.Kind (Type)
 import Data.List (partition, (\\))
@@ -25,6 +28,7 @@ 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 +132,10 @@ balanceTxIO pabConf ownPkh unbalancedTx =
       txWithoutFees <-
         hoistEither $ balanceTxStep minUtxos utxoIndex ownPkh $ tx `withFee` 0
 
-      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
+
+      let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget
 
       lift $ printLog @w Debug $ "Fees: " ++ show fees
 
@@ -140,6 +146,19 @@ balanceTxIO pabConf ownPkh unbalancedTx =
         then pure (balancedTx, minUtxos)
         else loop utxoIndex privKeys minUtxos balancedTx
 
+getExecutionUnitPrices :: PABConfig -> ExecutionUnitPrices
+getExecutionUnitPrices pabConf = fromMaybe (ExecutionUnitPrices 0 0) $ protocolParamPrices pabConf.pcProtocolParams
+
+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}