From baf393c5434e73de3568b8894ee0470cf1d07d2c Mon Sep 17 00:00:00 2001 From: zmrocze Date: Sat, 28 May 2022 17:50:29 +0200 Subject: [PATCH 1/3] Add option to collect logs inside ContractEnvironment. Adds additional interpretetion for PrintLog effect, that saves the log inside TVar in ContractEnviroment. This is turned on/off by flag in PABConfig. --- examples/plutus-game/app/Main.hs | 1 + examples/plutus-nft/app/Main.hs | 1 + examples/plutus-transfer/app/Main.hs | 1 + src/BotPlutusInterface/Effects.hs | 21 ++++++++++++++++++--- src/BotPlutusInterface/Server.hs | 2 ++ src/BotPlutusInterface/Types.hs | 15 +++++++++++++++ test/Spec/MockContract.hs | 1 + 7 files changed, 39 insertions(+), 3 deletions(-) diff --git a/examples/plutus-game/app/Main.hs b/examples/plutus-game/app/Main.hs index 6b3eaa7a..445330b2 100644 --- a/examples/plutus-game/app/Main.hs +++ b/examples/plutus-game/app/Main.hs @@ -69,5 +69,6 @@ main = do , pcEnableTxEndpoint = True , pcMetadataDir = "./metadata" , pcCollectStats = False + , pcCollectLogs = False } BotPlutusInterface.runPAB @GameContracts pabConf diff --git a/examples/plutus-nft/app/Main.hs b/examples/plutus-nft/app/Main.hs index bf23cf52..0a575610 100644 --- a/examples/plutus-nft/app/Main.hs +++ b/examples/plutus-nft/app/Main.hs @@ -65,5 +65,6 @@ main = do , pcEnableTxEndpoint = True , pcMetadataDir = "./metadata" , pcCollectStats = False + , pcCollectLogs = False } BotPlutusInterface.runPAB @MintNFTContracts pabConf diff --git a/examples/plutus-transfer/app/Main.hs b/examples/plutus-transfer/app/Main.hs index aa091053..8c5fac1c 100644 --- a/examples/plutus-transfer/app/Main.hs +++ b/examples/plutus-transfer/app/Main.hs @@ -68,5 +68,6 @@ main = do , pcEnableTxEndpoint = True , pcMetadataDir = "./metadata" , pcCollectStats = False + , pcCollectLogs = False } BotPlutusInterface.runPAB @TransferContracts pabConf diff --git a/src/BotPlutusInterface/Effects.hs b/src/BotPlutusInterface/Effects.hs index f44ef445..f689cff0 100644 --- a/src/BotPlutusInterface/Effects.hs +++ b/src/BotPlutusInterface/Effects.hs @@ -42,12 +42,13 @@ import BotPlutusInterface.Types ( TxBudget, TxFile, addBudget, + LogsList (LogsList), ) import Cardano.Api (AsType, FileError (FileIOError), HasTextEnvelope, TextEnvelopeDescr, TextEnvelopeError) import Cardano.Api qualified import Control.Concurrent qualified as Concurrent -import Control.Concurrent.STM (atomically, modifyTVar, modifyTVar') import Control.Lens ((^.)) +import Control.Concurrent.STM (atomically, modifyTVar, modifyTVar', TVar) import Control.Monad (void, when) import Control.Monad.Freer (Eff, LastMember, Member, interpretM, reinterpret, send, subsume, type (~>)) import Control.Monad.Freer.Extras (LogMsg (LMessage)) @@ -137,7 +138,11 @@ handlePABEffect contractEnv = case contractEnv.cePABConfig.pcCliLocation of Local -> Directory.createDirectoryIfMissing createParents filePath Remote ipAddr -> createDirectoryIfMissingRemote ipAddr createParents filePath - PrintLog logCtx logLevel txt -> printLog' contractEnv.cePABConfig.pcLogLevel logCtx logLevel txt + PrintLog logCtx logLevel txt -> + let logMsg = prettyLog logCtx logLevel txt in do + printLog' contractEnv.cePABConfig.pcLogLevel logCtx logLevel logMsg + when contractEnv.cePABConfig.pcCollectLogs $ + collectLog contractEnv.ceContractLogs logLevel logMsg UpdateInstanceState s -> do atomically $ modifyTVar contractEnv.ceContractState $ @@ -180,7 +185,17 @@ printLog' logLevelSetting msgCtx msgLogLvl msg = where target = Render.renderString . layoutPretty defaultLayoutOptions $ - pretty msgCtx <+> pretty msgLogLvl <+> msg + prettyLog msgCtx msgLogLvl msg + +prettyLog :: LogContext -> LogLevel -> PP.Doc () -> PP.Doc () +prettyLog msgCtx msgLogLvl msg = pretty msgCtx <+> pretty msgLogLvl <+> msg + +collectLog :: TVar LogsList -> LogLevel -> PP.Doc () -> IO () +collectLog logs msgLogLvl msg = atomically $ modifyTVar' logs (appendLog msgLogLvl msg) + where + appendLog :: LogLevel -> PP.Doc () -> LogsList -> LogsList + appendLog logLvl str (LogsList ls) = LogsList $ (logLvl, str) : ls + -- | Reinterpret contract logs to be handled by PABEffect later down the line. handleContractLog :: forall w a effs. Member (PABEffect w) effs => Pretty a => Eff (LogMsg a ': effs) ~> Eff effs diff --git a/src/BotPlutusInterface/Server.hs b/src/BotPlutusInterface/Server.hs index 21152f44..ee081a31 100644 --- a/src/BotPlutusInterface/Server.hs +++ b/src/BotPlutusInterface/Server.hs @@ -273,6 +273,7 @@ handleContract pabConf state@(AppState st) contract = liftIO $ do contractInstanceID <- liftIO $ ContractInstanceId <$> UUID.nextRandom contractState <- newTVarIO (ContractState Active mempty) contractStats <- newTVarIO mempty + contractLogs <- newTVarIO mempty atomically $ modifyTVar st (Map.insert contractInstanceID (SomeContractState contractState)) @@ -282,6 +283,7 @@ handleContract pabConf state@(AppState st) contract = liftIO $ do , ceContractState = contractState , ceContractInstanceId = contractInstanceID , ceContractStats = contractStats + , ceContractLogs = contractLogs } void $ forkIO $ do diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index 52f14c1b..ba0040c3 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -22,6 +22,7 @@ module BotPlutusInterface.Types ( SpendBudgets, MintBudgets, ContractStats (..), + LogsList (..), addBudget, ) where @@ -54,6 +55,7 @@ import Plutus.PAB.Effects.Contract.Builtin ( endpointsToSchemas, ) import Prettyprinter (Pretty (pretty)) +import Prettyprinter qualified as PP import Servant.Client (BaseUrl (BaseUrl), Scheme (Http)) import Wallet.Types (ContractInstanceId (..)) import Prelude @@ -83,6 +85,7 @@ data PABConfig = PABConfig , pcPort :: !Port , pcEnableTxEndpoint :: !Bool , pcCollectStats :: !Bool + , pcCollectLogs :: !Bool } deriving stock (Show, Eq) @@ -143,11 +146,22 @@ newtype ContractStats = ContractStats instance Show (TVar ContractStats) where show _ = "" +-- | List of string logs. +newtype LogsList = LogsList + { getLogsList :: [(LogLevel, PP.Doc ())] + } + deriving stock (Show) + deriving newtype (Semigroup, Monoid) + +instance Show (TVar LogsList) where + show _ = "" + data ContractEnvironment w = ContractEnvironment { cePABConfig :: PABConfig , ceContractInstanceId :: ContractInstanceId , ceContractState :: TVar (ContractState w) , ceContractStats :: TVar ContractStats + , ceContractLogs :: TVar LogsList } deriving stock (Show) @@ -221,6 +235,7 @@ instance Default PABConfig where , pcPort = 9080 , pcEnableTxEndpoint = False , pcCollectStats = False + , pcCollectLogs = False } data RawTx = RawTx diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index bbf75a7a..7d197e9c 100644 --- a/test/Spec/MockContract.hs +++ b/test/Spec/MockContract.hs @@ -255,6 +255,7 @@ instance Monoid w => Default (ContractEnvironment w) where , ceContractInstanceId = ContractInstanceId UUID.nil , ceContractState = unsafePerformIO $ newTVarIO def , ceContractStats = unsafePerformIO $ newTVarIO mempty + , ceContractLogs = unsafePerformIO $ newTVarIO mempty } instance Monoid w => Default (ContractState w) where From 51f847b15957875c2b4c5ca849c5c351a32e785a Mon Sep 17 00:00:00 2001 From: zmrocze Date: Tue, 7 Jun 2022 20:02:06 +0200 Subject: [PATCH 2/3] Comment & Format. --- README.md | 2 ++ src/BotPlutusInterface/Effects.hs | 16 ++++++++-------- src/BotPlutusInterface/Server.hs | 2 +- src/BotPlutusInterface/Types.hs | 10 ++++++---- 4 files changed, 17 insertions(+), 13 deletions(-) diff --git a/README.md b/README.md index 58a02e8e..0d46304a 100644 --- a/README.md +++ b/README.md @@ -100,6 +100,8 @@ main = do , pcEnableTxEndpoint = True -- Save some stats during contract run (only transactions execution budgets supported atm) , pcCollectStats = False + -- Save logs from contract execution: pab request logs and contract logs + , pcCollectLogs = False } BotPlutusInterface.runPAB @MyContracts pabConf ``` diff --git a/src/BotPlutusInterface/Effects.hs b/src/BotPlutusInterface/Effects.hs index f689cff0..9017e362 100644 --- a/src/BotPlutusInterface/Effects.hs +++ b/src/BotPlutusInterface/Effects.hs @@ -39,16 +39,16 @@ import BotPlutusInterface.Types ( ContractState (ContractState), LogContext (BpiLog, ContractLog), LogLevel (..), + LogsList (LogsList), TxBudget, TxFile, addBudget, - LogsList (LogsList), ) import Cardano.Api (AsType, FileError (FileIOError), HasTextEnvelope, TextEnvelopeDescr, TextEnvelopeError) import Cardano.Api qualified import Control.Concurrent qualified as Concurrent +import Control.Concurrent.STM (TVar, atomically, modifyTVar, modifyTVar') import Control.Lens ((^.)) -import Control.Concurrent.STM (atomically, modifyTVar, modifyTVar', TVar) import Control.Monad (void, when) import Control.Monad.Freer (Eff, LastMember, Member, interpretM, reinterpret, send, subsume, type (~>)) import Control.Monad.Freer.Extras (LogMsg (LMessage)) @@ -139,10 +139,11 @@ handlePABEffect contractEnv = Local -> Directory.createDirectoryIfMissing createParents filePath Remote ipAddr -> createDirectoryIfMissingRemote ipAddr createParents filePath PrintLog logCtx logLevel txt -> - let logMsg = prettyLog logCtx logLevel txt in do - printLog' contractEnv.cePABConfig.pcLogLevel logCtx logLevel logMsg - when contractEnv.cePABConfig.pcCollectLogs $ - collectLog contractEnv.ceContractLogs logLevel logMsg + let logMsg = prettyLog logCtx logLevel txt + in do + printLog' contractEnv.cePABConfig.pcLogLevel logCtx logLevel logMsg + when contractEnv.cePABConfig.pcCollectLogs $ + collectLog contractEnv.ceContractLogs logLevel logMsg UpdateInstanceState s -> do atomically $ modifyTVar contractEnv.ceContractState $ @@ -192,11 +193,10 @@ prettyLog msgCtx msgLogLvl msg = pretty msgCtx <+> pretty msgLogLvl <+> msg collectLog :: TVar LogsList -> LogLevel -> PP.Doc () -> IO () collectLog logs msgLogLvl msg = atomically $ modifyTVar' logs (appendLog msgLogLvl msg) - where + where appendLog :: LogLevel -> PP.Doc () -> LogsList -> LogsList appendLog logLvl str (LogsList ls) = LogsList $ (logLvl, str) : ls - -- | Reinterpret contract logs to be handled by PABEffect later down the line. handleContractLog :: forall w a effs. Member (PABEffect w) effs => Pretty a => Eff (LogMsg a ': effs) ~> Eff effs handleContractLog x = subsume $ handleContractLogInternal @w x diff --git a/src/BotPlutusInterface/Server.hs b/src/BotPlutusInterface/Server.hs index ee081a31..ec24adc3 100644 --- a/src/BotPlutusInterface/Server.hs +++ b/src/BotPlutusInterface/Server.hs @@ -283,7 +283,7 @@ handleContract pabConf state@(AppState st) contract = liftIO $ do , ceContractState = contractState , ceContractInstanceId = contractInstanceID , ceContractStats = contractStats - , ceContractLogs = contractLogs + , ceContractLogs = contractLogs } void $ forkIO $ do diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index ba0040c3..373f796f 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -84,8 +84,10 @@ data PABConfig = PABConfig , pcTipPollingInterval :: !Natural , pcPort :: !Port , pcEnableTxEndpoint :: !Bool - , pcCollectStats :: !Bool - , pcCollectLogs :: !Bool + , -- | Collect contract execution stats inside ContractEnvironment + pcCollectStats :: !Bool + , -- | Collect logs inside ContractEnvironment, doesn't depend on log level + pcCollectLogs :: !Bool } deriving stock (Show, Eq) @@ -153,7 +155,7 @@ newtype LogsList = LogsList deriving stock (Show) deriving newtype (Semigroup, Monoid) -instance Show (TVar LogsList) where +instance Show (TVar LogsList) where show _ = "" data ContractEnvironment w = ContractEnvironment @@ -161,7 +163,7 @@ data ContractEnvironment w = ContractEnvironment , ceContractInstanceId :: ContractInstanceId , ceContractState :: TVar (ContractState w) , ceContractStats :: TVar ContractStats - , ceContractLogs :: TVar LogsList + , ceContractLogs :: TVar LogsList } deriving stock (Show) From 12b54288155f2a3f4e19b81484adf646e9737ff7 Mon Sep 17 00:00:00 2001 From: zmrocze Date: Tue, 7 Jun 2022 22:10:52 +0200 Subject: [PATCH 3/3] Collect LogContext as well. --- src/BotPlutusInterface/Effects.hs | 9 ++++----- src/BotPlutusInterface/Types.hs | 2 +- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/src/BotPlutusInterface/Effects.hs b/src/BotPlutusInterface/Effects.hs index 9017e362..55509e6e 100644 --- a/src/BotPlutusInterface/Effects.hs +++ b/src/BotPlutusInterface/Effects.hs @@ -143,7 +143,7 @@ handlePABEffect contractEnv = in do printLog' contractEnv.cePABConfig.pcLogLevel logCtx logLevel logMsg when contractEnv.cePABConfig.pcCollectLogs $ - collectLog contractEnv.ceContractLogs logLevel logMsg + collectLog contractEnv.ceContractLogs logCtx logLevel logMsg UpdateInstanceState s -> do atomically $ modifyTVar contractEnv.ceContractState $ @@ -191,11 +191,10 @@ printLog' logLevelSetting msgCtx msgLogLvl msg = prettyLog :: LogContext -> LogLevel -> PP.Doc () -> PP.Doc () prettyLog msgCtx msgLogLvl msg = pretty msgCtx <+> pretty msgLogLvl <+> msg -collectLog :: TVar LogsList -> LogLevel -> PP.Doc () -> IO () -collectLog logs msgLogLvl msg = atomically $ modifyTVar' logs (appendLog msgLogLvl msg) +collectLog :: TVar LogsList -> LogContext -> LogLevel -> PP.Doc () -> IO () +collectLog logs logCtx logLvl msg = atomically $ modifyTVar' logs appendLog where - appendLog :: LogLevel -> PP.Doc () -> LogsList -> LogsList - appendLog logLvl str (LogsList ls) = LogsList $ (logLvl, str) : ls + appendLog (LogsList ls) = LogsList $ (logCtx, logLvl, msg) : ls -- | Reinterpret contract logs to be handled by PABEffect later down the line. handleContractLog :: forall w a effs. Member (PABEffect w) effs => Pretty a => Eff (LogMsg a ': effs) ~> Eff effs diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index 373f796f..4f69c787 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -150,7 +150,7 @@ instance Show (TVar ContractStats) where -- | List of string logs. newtype LogsList = LogsList - { getLogsList :: [(LogLevel, PP.Doc ())] + { getLogsList :: [(LogContext, LogLevel, PP.Doc ())] } deriving stock (Show) deriving newtype (Semigroup, Monoid)