saving execution budgets

- option to save budgets to contract environment

Author: mikekeke

README.md

@@ -99,6 +99,8 @@ main = do
           , -- Protocol params file location relative to the cardano-cli working directory (needed for the cli)
           , pcProtocolParamsFile = "./protocol.json"
           , pcEnableTxEndpoint = True
+          -- Save some stats during contract run (only transactions execution budgets supported atm)
+          , pcCollectStats = False
           }
   BotPlutusInterface.runPAB @MyContracts pabConf
 ```

bot-plutus-interface.cabal

@@ -25,8 +25,7 @@ source-repository head
 common common-lang
   ghc-options:
     -Wall -Wcompat -Wincomplete-record-updates
-    -Wincomplete-uni-patterns -Wredundant-constraints 
-    -- -Werror
+    -Wincomplete-uni-patterns -Wredundant-constraints -Werror
     -fobject-code -fno-ignore-interface-pragmas
     -fno-omit-interface-pragmas -fplugin=RecordDotPreprocessor
 
@@ -150,10 +149,11 @@ test-suite bot-plutus-interface-test
   main-is:        Spec.hs
   ghc-options:    -fplugin-opt PlutusTx.Plugin:defer-errors
   other-modules:
-    Spec.BotPlutusInterface.Contract
     Spec.BotPlutusInterface.Balance
-    Spec.BotPlutusInterface.UtxoParser
+    Spec.BotPlutusInterface.Contract
+    Spec.BotPlutusInterface.ContractStats
     Spec.BotPlutusInterface.Server
+    Spec.BotPlutusInterface.UtxoParser
     Spec.MockContract
 
   build-depends:

examples/plutus-game/app/Main.hs

@@ -69,5 +69,6 @@ main = do
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
           , pcEnableTxEndpoint = True
+          , pcCollectStats = False
           }
   BotPlutusInterface.runPAB @GameContracts pabConf

examples/plutus-nft/app/Main.hs

@@ -69,5 +69,6 @@ main = do
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
           , pcEnableTxEndpoint = True
+          , pcCollectStats = False
           }
   BotPlutusInterface.runPAB @MintNFTContracts pabConf

examples/plutus-transfer/app/Main.hs

@@ -68,5 +68,6 @@ main = do
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
           , pcEnableTxEndpoint = True
+          , pcCollectStats = False
           }
   BotPlutusInterface.runPAB @TransferContracts pabConf

src/BotPlutusInterface/Contract.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE RankNTypes #-}
 
-module BotPlutusInterface.Contract (runContract, runContract', handleContract) where
+module BotPlutusInterface.Contract (runContract, handleContract) where
 
 import BotPlutusInterface.Balance qualified as PreBalance
 import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
@@ -28,11 +28,8 @@ import BotPlutusInterface.Types (
   LogLevel (Debug, Warn),
   Tip (block, slot),
   TxFile (Signed),
-  TxStats,
-  emptyStats,
  )
 import Cardano.Api (AsType (..), EraInMode (..), Tx (Tx))
-import Control.Concurrent.STM (newTVarIO, readTVarIO)
 import Control.Lens (preview, (^.))
 import Control.Monad (join, void, when)
 import Control.Monad.Freer (Eff, Member, interpret, reinterpret, runM, subsume, type (~>))
@@ -81,20 +78,8 @@ runContract ::
   ContractEnvironment w ->
   Contract w s e a ->
   IO (Either e a)
-runContract contractEnv contract =
-  fst <$> runContract' contractEnv contract
-
-runContract' ::
-  forall (w :: Type) (s :: Row Type) (e :: Type) (a :: Type).
-  (ToJSON w, Monoid w) =>
-  ContractEnvironment w ->
-  Contract w s e a ->
-  IO (Either e a, TxStats)
-runContract' contractEnv (Contract effs) = do
-  emptyBudgets <- newTVarIO emptyStats
-  res <- runM $ handlePABEffect @w contractEnv emptyBudgets $ raiseEnd $ handleContract contractEnv effs
-  budgets <- readTVarIO emptyBudgets
-  return (res, budgets)
+runContract contractEnv (Contract effs) = do
+  runM $ handlePABEffect @w contractEnv $ raiseEnd $ handleContract contractEnv effs
 
 handleContract ::
   forall (w :: Type) (e :: Type) (a :: Type).
@@ -292,14 +277,14 @@ writeBalancedTx contractEnv (Right tx) = do
       newEitherT $ CardanoCLI.submitTx @w pabConf tx
 
     -- We need to replace the outfile we created at the previous step, as it currently still has the old (incorrect) id
-    mvFiles (Files.txFilePath pabConf "raw" (Tx.txId tx)) (Files.txFilePath pabConf "raw" (Ledger.getCardanoTxId $ Left cardanoTx))
-    when signable $ mvFiles (Files.txFilePath pabConf "signed" (Tx.txId tx)) (Files.txFilePath pabConf "signed" (Ledger.getCardanoTxId $ Left cardanoTx))
-
-    let txId = Ledger.getCardanoTxId $ Left cardanoTx
-        path = Text.unpack $ Files.txFilePath pabConf "signed" txId
-    b <- firstEitherT (Text.pack . show) $ newEitherT $ estimateBudget @w (Signed path)
+    let cardanoTxId = Ledger.getCardanoTxId $ Left cardanoTx
+        signedSrcPath = Files.txFilePath pabConf "signed" (Tx.txId tx)
+        signedDstPath = Files.txFilePath pabConf "signed" cardanoTxId
+    mvFiles (Files.txFilePath pabConf "raw" (Tx.txId tx)) (Files.txFilePath pabConf "raw" cardanoTxId)
+    when signable $ mvFiles signedSrcPath signedDstPath
 
-    _ <- newEitherT (Right <$> saveBudget @w txId b)
+    when contractEnv.cePABConfig.pcCollectStats $
+      collectBudgetStats cardanoTxId signedDstPath
 
     pure cardanoTx
   where
@@ -313,6 +298,11 @@ writeBalancedTx contractEnv (Right tx) = do
             , cmdOutParser = const ()
             }
 
+    collectBudgetStats txId txPath = do
+      let path = Text.unpack txPath
+      b <- firstEitherT (Text.pack . show) $ newEitherT $ estimateBudget @w (Signed path)
+      void $ newEitherT (Right <$> saveBudget @w txId b)
+
 pkhToText :: Ledger.PubKey -> Text
 pkhToText = encodeByteString . fromBuiltin . Ledger.getPubKeyHash . Ledger.pubKeyHash
 

src/BotPlutusInterface/Effects.hs

@@ -33,13 +33,12 @@ import BotPlutusInterface.Types (
   LogLevel (..),
   TxBudget,
   TxFile,
-  TxStats,
   addBudget,
  )
 import Cardano.Api (AsType, FileError, HasTextEnvelope, TextEnvelopeDescr, TextEnvelopeError)
 import Cardano.Api qualified
 import Control.Concurrent qualified as Concurrent
-import Control.Concurrent.STM (TVar, atomically, modifyTVar, modifyTVar')
+import Control.Concurrent.STM (atomically, modifyTVar, modifyTVar')
 import Control.Monad (void, when)
 import Control.Monad.Freer (Eff, LastMember, Member, interpretM, send, type (~>))
 import Data.Aeson (ToJSON)
@@ -99,9 +98,8 @@ handlePABEffect ::
   LastMember IO effs =>
   (Monoid w) =>
   ContractEnvironment w ->
-  TVar TxStats ->
   Eff (PABEffect w ': effs) ~> Eff effs
-handlePABEffect contractEnv txStatsVar =
+handlePABEffect contractEnv =
   interpretM
     ( \case
         CallCommand shellArgs ->
@@ -138,13 +136,9 @@ handlePABEffect contractEnv txStatsVar =
           handleChainIndexReq contractEnv.cePABConfig query
         EstimateBudget txPath ->
           Estimate.estimateBudget contractEnv.cePABConfig txPath
-        SaveBudget txId exBudget -> saveBudgetImpl txStatsVar txId exBudget
+        SaveBudget txId exBudget -> saveBudgetImpl contractEnv txId exBudget
     )
 
-saveBudgetImpl :: TVar TxStats -> Ledger.TxId -> TxBudget -> IO ()
-saveBudgetImpl txStatsVar txId budget =
-  atomically $ modifyTVar' txStatsVar (addBudget txId budget)
-
 printLog' :: LogLevel -> LogLevel -> String -> IO ()
 printLog' logLevelSetting msgLogLvl msg =
   when (logLevelSetting >= msgLogLvl) $ putStrLn msg
@@ -179,6 +173,11 @@ readProcessEither path args =
     mapToEither (ExitFailure exitCode, _, stderr) =
       Left $ "ExitCode " <> Text.pack (show exitCode) <> ": " <> Text.pack stderr
 
+saveBudgetImpl :: ContractEnvironment w -> Ledger.TxId -> TxBudget -> IO ()
+saveBudgetImpl contractEnv txId budget =
+  atomically $
+    modifyTVar' contractEnv.ceContractStats (addBudget txId budget)
+
 -- Couldn't use the template haskell makeEffect here, because it caused an OverlappingInstances problem.
 -- For some reason, we need to manually propagate the @w@ type variable to @send@
 

src/BotPlutusInterface/Server.hs

@@ -256,6 +256,7 @@ handleContract ::
 handleContract pabConf state@(AppState st) contract = liftIO $ do
   contractInstanceID <- liftIO $ ContractInstanceId <$> UUID.nextRandom
   contractState <- newTVarIO (ContractState Active mempty)
+  contractStats <- newTVarIO mempty
 
   atomically $ modifyTVar st (Map.insert contractInstanceID (SomeContractState contractState))
 
@@ -264,6 +265,7 @@ handleContract pabConf state@(AppState st) contract = liftIO $ do
           { cePABConfig = pabConf
           , ceContractState = contractState
           , ceContractInstanceId = contractInstanceID
+          , ceContractStats = contractStats
           }
   void $
     forkIO $ do

src/BotPlutusInterface/Types.hs

@@ -20,7 +20,7 @@ module BotPlutusInterface.Types (
   BudgetEstimationError (..),
   SpendBudgets,
   MintBudgets,
-  TxStats(..),
+  ContractStats (..),
   emptyStats,
   addBudget,
 ) where
@@ -82,13 +82,76 @@ data PABConfig = PABConfig
   , pcTipPollingInterval :: !Natural
   , pcPort :: !Port
   , pcEnableTxEndpoint :: !Bool
+  , pcCollectStats :: !Bool
   }
   deriving stock (Show, Eq)
 
+-- Budget estimation types
+
+{- | Error returned in case any error happened during budget estimation
+ (wraps whatever received in `Text`)
+-}
+data BudgetEstimationError
+  = -- | general error for `Cardano.Api` errors
+    BudgetEstimationError !Text
+  | -- | script evaluation failed during budget estimation
+    ScriptFailure ScriptExecutionError
+  | {- budget for input or policy was not found after estimation
+       (arguably should not happen at all) -}
+    BudgetNotFound ScriptWitnessIndex
+  deriving stock (Show)
+
+-- | Type of transaction file used for budget estimation
+data TxFile
+  = -- | for using with ".raw" files
+    Raw !FilePath
+  | -- | for using with ".signed" files
+    Signed !FilePath
+
+-- TODO; maybe, Monoid instance could be handy later
+emptyStats :: ContractStats
+emptyStats = ContractStats mempty
+
+addBudget :: TxId -> TxBudget -> ContractStats -> ContractStats
+addBudget txId budget stats =
+  stats {estimatedBudgets = Map.insert txId budget (estimatedBudgets stats)}
+
+-- | Result of budget estimation
+data TxBudget = TxBudget
+  { -- | budgets for spending inputs
+    spendBudgets :: !SpendBudgets
+  , -- | budgets for minting policies
+    mintBudgets :: !MintBudgets
+  }
+  deriving stock (Show)
+
+instance Semigroup TxBudget where
+  TxBudget s m <> TxBudget s' m' = TxBudget (s <> s') (m <> m')
+
+instance Monoid TxBudget where
+  mempty = TxBudget mempty mempty
+
+type SpendBudgets = Map TxOutRef ExBudget
+
+type MintBudgets = Map MintingPolicyHash ExBudget
+
+{- | Collection of stats that could be collected py `bpi`
+   about contract it runs
+-}
+newtype ContractStats = ContractStats
+  { estimatedBudgets :: Map TxId TxBudget
+  }
+  deriving stock (Show)
+  deriving newtype (Semigroup, Monoid)
+
+instance Show (TVar ContractStats) where
+  show _ = "<ContractStats>"
+
 data ContractEnvironment w = ContractEnvironment
   { cePABConfig :: PABConfig
   , ceContractInstanceId :: ContractInstanceId
   , ceContractState :: TVar (ContractState w)
+  , ceContractStats :: TVar ContractStats
   }
   deriving stock (Show)
 
@@ -145,6 +208,7 @@ instance Default PABConfig where
       , pcOwnStakePubKeyHash = Nothing
       , pcPort = 9080
       , pcEnableTxEndpoint = False
+      , pcCollectStats = False
       }
 
 data RawTx = RawTx
@@ -157,60 +221,3 @@ data RawTx = RawTx
 -- type is a reserved keyword in haskell and can not be used as a field name
 -- when converting this to JSON we drop the _ prefix from each field
 deriveJSON defaultOptions {fieldLabelModifier = drop 1} ''RawTx
-
--- Budget estimation types
-
-{- | Error returned in case any error happened during budget estimation
- (wraps whatever received in `Text`)
--}
-data BudgetEstimationError
-  = -- | general error for `Cardano.Api` errors
-    BudgetEstimationError !Text
-  | -- | script evaluation failed during budget estimation
-    ScriptFailure ScriptExecutionError
-  | {- budget for input or policy was not found after estimation
-       (arguably should not happen at all) -}
-    BudgetNotFound ScriptWitnessIndex
-  deriving stock (Show)
-
--- | Type of transaction file used for budget estimation
-data TxFile
-  = -- | for using with ".raw" files
-    Raw !FilePath
-  | -- | for using with ".signed" files
-    Signed !FilePath
-
-{- | WIP: Collection of various stats that could be collected py `bpi`
-   about transactions it performs
--}
-data TxStats = TxStats
-  { estimatedBudgets :: !(Map TxId TxBudget)
-  }
-  deriving stock Show
-
--- TODO; maybe, Monoid instance could be handy later
-emptyStats :: TxStats
-emptyStats = TxStats mempty
-
-addBudget :: TxId -> TxBudget -> TxStats -> TxStats
-addBudget txId budget stats =
-  stats {estimatedBudgets = Map.insert txId budget (estimatedBudgets stats)}
-
--- | Result of budget estimation
-data TxBudget = TxBudget
-  { -- | budgets for spending inputs
-    spendBudgets :: !SpendBudgets
-  , -- | budgets for minting policies
-    mintBudgets :: !MintBudgets
-  }
-  deriving stock (Show)
-
-instance Semigroup TxBudget where
-  TxBudget s m <> TxBudget s' m' = TxBudget (s <> s') (m <> m')
-
-instance Monoid TxBudget where
-  mempty = TxBudget mempty mempty
-
-type SpendBudgets = Map TxOutRef ExBudget
-
-type MintBudgets = Map MintingPolicyHash ExBudget

test/Spec.hs

@@ -2,6 +2,7 @@ module Main (main) where
 
 import Spec.BotPlutusInterface.Balance qualified
 import Spec.BotPlutusInterface.Contract qualified
+import Spec.BotPlutusInterface.ContractStats qualified
 import Spec.BotPlutusInterface.Server qualified
 import Spec.BotPlutusInterface.UtxoParser qualified
 import Test.Tasty (TestTree, defaultMain, testGroup)
@@ -23,4 +24,5 @@ tests =
     , Spec.BotPlutusInterface.UtxoParser.tests
     , Spec.BotPlutusInterface.Balance.tests
     , Spec.BotPlutusInterface.Server.tests
+    , Spec.BotPlutusInterface.ContractStats.tests
     ]