Merge pull request #92 from mlabs-haskell/misha/return-ex-units

Misha/return ex units

Author: szg251

README.md

@@ -100,6 +100,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

@@ -152,6 +152,7 @@ test-suite bot-plutus-interface-test
   other-modules:
     Spec.BotPlutusInterface.Balance
     Spec.BotPlutusInterface.Contract
+    Spec.BotPlutusInterface.ContractStats
     Spec.BotPlutusInterface.Server
     Spec.BotPlutusInterface.UtxoParser
     Spec.MockContract

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/CardanoCLI.hs

@@ -24,7 +24,15 @@ import BotPlutusInterface.Files (
   txFilePath,
   validatorScriptFilePath,
  )
-import BotPlutusInterface.Types (MintBudgets, PABConfig, SpendBudgets, Tip, TxBudget, mintBudgets, spendBudgets)
+import BotPlutusInterface.Types (
+  MintBudgets,
+  PABConfig,
+  SpendBudgets,
+  Tip,
+  TxBudget,
+  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,17 +11,24 @@ import BotPlutusInterface.Effects (
   ShellArgs (..),
   callCommand,
   createDirectoryIfMissing,
+  estimateBudget,
   handlePABEffect,
   logToContract,
   printLog,
   queryChainIndex,
   readFileTextEnvelope,
+  saveBudget,
   threadDelay,
   uploadDir,
  )
 import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey))
 import BotPlutusInterface.Files qualified as Files
-import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug, Warn), Tip (block, slot))
+import BotPlutusInterface.Types (
+  ContractEnvironment (..),
+  LogLevel (Debug, Warn),
+  Tip (block, slot),
+  TxFile (Signed),
+ )
 import Cardano.Api (AsType (..), EraInMode (..), Tx (Tx))
 import Control.Lens (preview, (^.))
 import Control.Monad (join, void, when)
@@ -271,8 +278,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 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
+
+    when contractEnv.cePABConfig.pcCollectStats $
+      collectBudgetStats cardanoTxId signedDstPath
 
     pure cardanoTx
   where
@@ -286,6 +299,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

@@ -20,6 +20,7 @@ module BotPlutusInterface.Effects (
   writeFileTextEnvelope,
   callCommand,
   estimateBudget,
+  saveBudget,
 ) where
 
 import BotPlutusInterface.ChainIndex (handleChainIndexReq)
@@ -32,11 +33,12 @@ import BotPlutusInterface.Types (
   LogLevel (..),
   TxBudget,
   TxFile,
+  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 (atomically, modifyTVar, modifyTVar')
 import Control.Monad (void, when)
 import Control.Monad.Freer (Eff, LastMember, Member, interpretM, send, type (~>))
 import Data.Aeson (ToJSON)
@@ -47,6 +49,7 @@ 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
@@ -88,6 +91,7 @@ data PABEffect (w :: Type) (r :: Type) where
   UploadDir :: Text -> PABEffect w ()
   QueryChainIndex :: ChainIndexQuery -> PABEffect w ChainIndexResponse
   EstimateBudget :: TxFile -> PABEffect w (Either BudgetEstimationError TxBudget)
+  SaveBudget :: Ledger.TxId -> TxBudget -> PABEffect w ()
 
 handlePABEffect ::
   forall (w :: Type) (effs :: [Type -> Type]).
@@ -132,6 +136,7 @@ handlePABEffect contractEnv =
           handleChainIndexReq contractEnv.cePABConfig query
         EstimateBudget txPath ->
           ExBudget.estimateBudget contractEnv.cePABConfig txPath
+        SaveBudget txId exBudget -> saveBudgetImpl contractEnv txId exBudget
     )
 
 printLog' :: LogLevel -> LogLevel -> String -> IO ()
@@ -168,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@
 
@@ -267,3 +277,11 @@ queryChainIndex ::
   ChainIndexQuery ->
   Eff effs ChainIndexResponse
 queryChainIndex = send @(PABEffect w) . QueryChainIndex
+
+saveBudget ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  Ledger.TxId ->
+  TxBudget ->
+  Eff effs ()
+saveBudget txId budget = send @(PABEffect w) $ SaveBudget txId budget

src/BotPlutusInterface/Server.hs

@@ -272,6 +272,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))
 
@@ -280,6 +281,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,6 +20,8 @@ module BotPlutusInterface.Types (
   BudgetEstimationError (..),
   SpendBudgets,
   MintBudgets,
+  ContractStats (..),
+  addBudget,
 ) where
 
 import Cardano.Api (NetworkId (Testnet), NetworkMagic (..), ScriptExecutionError, ScriptWitnessIndex)
@@ -31,13 +33,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)
@@ -77,13 +81,72 @@ 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
+
+-- | Result of budget estimation
+data TxBudget = TxBudget
+  { -- | budgets for spending inputs
+    spendBudgets :: !SpendBudgets
+  , -- | budgets for minting policies
+    mintBudgets :: !MintBudgets
+  }
+  deriving stock (Show)
+
+addBudget :: TxId -> TxBudget -> ContractStats -> ContractStats
+addBudget txId budget stats =
+  stats {estimatedBudgets = Map.insert txId budget (estimatedBudgets stats)}
+
+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)
 
@@ -140,6 +203,7 @@ instance Default PABConfig where
       , pcOwnStakePubKeyHash = Nothing
       , pcPort = 9080
       , pcEnableTxEndpoint = False
+      , pcCollectStats = False
       }
 
 data RawTx = RawTx
@@ -152,44 +216,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
-
--- | 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