wip: bpi returns tx stats with contract result

Author: mikekeke

src/BotPlutusInterface/CardanoCLI.hs

@@ -25,7 +25,16 @@ import BotPlutusInterface.Files (
   txFilePath,
   validatorScriptFilePath,
  )
-import BotPlutusInterface.Types (MintBudgets, PABConfig, SpendBudgets, Tip, TxBudget, emptyBudget, mintBudgets, spendBudgets)
+import BotPlutusInterface.Types (
+  MintBudgets,
+  PABConfig,
+  SpendBudgets,
+  Tip,
+  TxBudget,
+  emptyBudget,
+  mintBudgets,
+  spendBudgets,
+ )
 import BotPlutusInterface.UtxoParser qualified as UtxoParser
 import Cardano.Api.Shelley (NetworkId (Mainnet, Testnet), NetworkMagic (..), serialiseAddress)
 import Control.Monad (join)

src/BotPlutusInterface/Contract.hs

@@ -11,18 +11,28 @@ import BotPlutusInterface.Effects (
   ShellArgs (..),
   callCommand,
   createDirectoryIfMissing,
+  estimateBudget,
   handlePABEffect,
   logToContract,
   printLog,
   queryChainIndex,
   readFileTextEnvelope,
+  saveBudget,
   threadDelay,
-  uploadDir, estimateBudget, saveBudget
+  uploadDir,
  )
 import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey))
 import BotPlutusInterface.Files qualified as Files
-import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug, Warn), Tip (block, slot), Budgets, TxFile (Signed), TxBudget)
+import BotPlutusInterface.Types (
+  ContractEnvironment (..),
+  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 (~>))
@@ -64,29 +74,27 @@ import Plutus.Contract.Types (Contract (..), ContractEffs)
 import PlutusTx.Builtins (fromBuiltin)
 import Wallet.Emulator.Error (WalletAPIError (..))
 import Prelude
-import Control.Concurrent.STM (newTVarIO, readTVarIO)
-import Data.Map (Map)
 
 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)
-runContract contractEnv contract = 
+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, Map Text TxBudget)
+  IO (Either e a, TxStats)
 runContract' contractEnv (Contract effs) = do
-  emptyBudgets :: Budgets <- newTVarIO mempty
+  emptyBudgets <- newTVarIO emptyStats
   res <- runM $ handlePABEffect @w contractEnv emptyBudgets $ raiseEnd $ handleContract contractEnv effs
   budgets <- readTVarIO emptyBudgets
-  return (res,budgets)
+  return (res, budgets)
 
 handleContract ::
   forall (w :: Type) (e :: Type) (a :: Type).
@@ -286,12 +294,12 @@ writeBalancedTx contractEnv (Right tx) = do
     -- 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)
 
-    _ <- newEitherT (Right <$> saveBudget @w (Text.pack $ show txId) b)
+    _ <- newEitherT (Right <$> saveBudget @w txId b)
 
     pure cardanoTx
   where

src/BotPlutusInterface/Effects.hs

@@ -20,7 +20,8 @@ module BotPlutusInterface.Effects (
   writeFileTextEnvelope,
   callCommand,
   estimateBudget,
-saveBudget) where
+  saveBudget,
+) where
 
 import BotPlutusInterface.ChainIndex (handleChainIndexReq)
 import BotPlutusInterface.Estimate qualified as Estimate
@@ -31,12 +32,14 @@ import BotPlutusInterface.Types (
   ContractState (ContractState),
   LogLevel (..),
   TxBudget,
-  TxFile, Budgets
+  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 (atomically, modifyTVar)
+import Control.Concurrent.STM (TVar, atomically, modifyTVar, modifyTVar')
 import Control.Monad (void, when)
 import Control.Monad.Freer (Eff, LastMember, Member, interpretM, send, type (~>))
 import Data.Aeson (ToJSON)
@@ -47,13 +50,13 @@ import Data.Maybe (catMaybes)
 import Data.String (IsString, fromString)
 import Data.Text (Text)
 import Data.Text qualified as Text
+import Ledger qualified
 import Plutus.Contract.Effects (ChainIndexQuery, ChainIndexResponse)
 import Plutus.PAB.Core.ContractInstance.STM (Activity)
 import System.Directory qualified as Directory
 import System.Exit (ExitCode (ExitFailure, ExitSuccess))
 import System.Process (readProcess, readProcessWithExitCode)
 import Prelude hiding (readFile)
-import Data.Map qualified as Map
 
 data ShellArgs a = ShellArgs
   { cmdName :: Text
@@ -89,16 +92,16 @@ data PABEffect (w :: Type) (r :: Type) where
   UploadDir :: Text -> PABEffect w ()
   QueryChainIndex :: ChainIndexQuery -> PABEffect w ChainIndexResponse
   EstimateBudget :: TxFile -> PABEffect w (Either BudgetEstimationError TxBudget)
-  SaveBudget :: Text -> TxBudget -> PABEffect w ()
+  SaveBudget :: Ledger.TxId -> TxBudget -> PABEffect w ()
 
 handlePABEffect ::
   forall (w :: Type) (effs :: [Type -> Type]).
   LastMember IO effs =>
   (Monoid w) =>
   ContractEnvironment w ->
-  Budgets ->
+  TVar TxStats ->
   Eff (PABEffect w ': effs) ~> Eff effs
-handlePABEffect contractEnv budgets =
+handlePABEffect contractEnv txStatsVar =
   interpretM
     ( \case
         CallCommand shellArgs ->
@@ -135,11 +138,12 @@ handlePABEffect contractEnv budgets =
           handleChainIndexReq contractEnv.cePABConfig query
         EstimateBudget txPath ->
           Estimate.estimateBudget contractEnv.cePABConfig txPath
-        SaveBudget txId exBudget -> saveBudgetImpl budgets txId exBudget
+        SaveBudget txId exBudget -> saveBudgetImpl txStatsVar txId exBudget
     )
 
-saveBudgetImpl budgets txId budget = 
-  atomically $ modifyTVar budgets (Map.insert txId budget)
+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 =
@@ -275,12 +279,10 @@ queryChainIndex ::
   Eff effs ChainIndexResponse
 queryChainIndex = send @(PABEffect w) . QueryChainIndex
 
-
-
 saveBudget ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
-  Text -> 
-  TxBudget  ->
+  Ledger.TxId ->
+  TxBudget ->
   Eff effs ()
-saveBudget txId budget = send @(PABEffect w) $ SaveBudget txId budget
+saveBudget txId budget = send @(PABEffect w) $ SaveBudget txId budget

src/BotPlutusInterface/Types.hs

@@ -20,8 +20,11 @@ module BotPlutusInterface.Types (
   BudgetEstimationError (..),
   SpendBudgets,
   MintBudgets,
+  TxStats,
+  emptyStats,
+  addBudget,
   emptyBudget,
-Budgets) where
+) where
 
 import Cardano.Api (NetworkId (Testnet), NetworkMagic (..), ScriptExecutionError, ScriptWitnessIndex)
 import Cardano.Api.ProtocolParameters (ProtocolParameters)
@@ -32,13 +35,15 @@ import Data.Aeson.TH (Options (..), defaultOptions, deriveJSON)
 import Data.Default (Default (def))
 import Data.Kind (Type)
 import Data.Map (Map)
+import Data.Map qualified as Map
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Ledger (
   ExBudget,
   MintingPolicyHash,
   PubKeyHash,
   StakePubKeyHash,
+  TxId,
   TxOutRef,
  )
 import Ledger.TimeSlot (SlotConfig)
@@ -176,6 +181,21 @@ data TxFile
   | -- | 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)
+  }
+
+-- 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
@@ -192,6 +212,3 @@ emptyBudget = TxBudget mempty mempty
 type SpendBudgets = Map TxOutRef ExBudget
 
 type MintBudgets = Map MintingPolicyHash ExBudget
-
-
-type Budgets = TVar (Map Text TxBudget)

test/Spec/MockContract.hs

@@ -298,6 +298,7 @@ runPABEffectPure initState req =
     go (UploadDir dir) = mockUploadDir dir
     go (QueryChainIndex query) = mockQueryChainIndex query
     go (EstimateBudget file) = mockExBudget file
+    go (SaveBudget _ _) = pure () -- TODO
     incSlot :: forall (v :: Type). MockContract w v -> MockContract w v
     incSlot mc =
       mc <* modify @(MockContractState w) (tip %~ incTip)