Refactor PrintLog with log context

Author: TotallyNotChase

bot-plutus-interface.cabal

@@ -175,6 +175,7 @@ test-suite bot-plutus-interface-test
     , data-default-class
     , either
     , extra
+    , prettyprinter
     , filepath
     , freer-extras
     , freer-simple

src/BotPlutusInterface/Balance.hs

@@ -7,7 +7,7 @@ module BotPlutusInterface.Balance (
 ) where
 
 import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
-import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissingCLI, printLog)
+import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissingCLI, printBpiLog)
 import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
 import BotPlutusInterface.Files qualified as Files
 import BotPlutusInterface.Types (LogLevel (Debug), PABConfig)
@@ -60,6 +60,7 @@ import Plutus.V1.Ledger.Api (
  )
 
 import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
+import Prettyprinter (pretty, viaShow, (<+>))
 import Prelude
 
 {- | Collect necessary tx inputs and collaterals, add minimum lovelace values and balance non ada
@@ -86,7 +87,7 @@ balanceTxIO pabConf ownPkh unbalancedTx =
             (unBalancedTxValidityTimeRange unbalancedTx)
             (unBalancedTxTx unbalancedTx)
 
-      lift $ printLog @w Debug $ show utxoIndex
+      lift $ printBpiLog @w Debug $ viaShow utxoIndex
 
       -- We need this folder on the CLI machine, which may not be the local machine
       lift $ createDirectoryIfMissingCLI @w False (Text.unpack pabConf.pcTxFileDir)
@@ -130,7 +131,7 @@ balanceTxIO pabConf ownPkh unbalancedTx =
 
       let minUtxos = prevMinUtxos ++ nextMinUtxos
 
-      lift $ printLog @w Debug $ "Min utxos: " ++ show minUtxos
+      lift $ printBpiLog @w Debug $ "Min utxos:" <+> pretty minUtxos
 
       -- Calculate fees by pre-balancing the tx, building it, and running the CLI on result
       txWithoutFees <-
@@ -142,7 +143,7 @@ balanceTxIO pabConf ownPkh unbalancedTx =
 
       let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget
 
-      lift $ printLog @w Debug $ "Fees: " ++ show fees
+      lift $ printBpiLog @w Debug $ "Fees:" <+> pretty fees
 
       -- Rebalance the initial tx with the above fees
       balancedTx <- hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` fees

src/BotPlutusInterface/Contract.hs

@@ -16,7 +16,7 @@ import BotPlutusInterface.Effects (
   handleContractLog,
   handlePABEffect,
   logToContract,
-  printLog,
+  printBpiLog,
   queryChainIndex,
   readFileTextEnvelope,
   saveBudget,
@@ -164,7 +164,7 @@ handlePABReq ::
   PABReq ->
   Eff effs PABResp
 handlePABReq contractEnv req = do
-  printLog @w Debug $ show req
+  printBpiLog @w Debug $ pretty req
   resp <- case req of
     ----------------------
     -- Handled requests --
@@ -200,7 +200,7 @@ handlePABReq contractEnv req = do
     -- YieldUnbalancedTxReq UnbalancedTx
     unsupported -> error ("Unsupported PAB effect: " ++ show unsupported)
 
-  printLog @w Debug $ show resp
+  printBpiLog @w Debug $ pretty resp
   pure resp
 
 awaitTxStatusChange ::
@@ -217,7 +217,7 @@ awaitTxStatusChange contractEnv txId = do
   case mTx of
     Nothing -> pure Unknown
     Just txState -> do
-      printLog @w Debug $ "Found transaction in node, waiting " ++ show chainConstant ++ " blocks for it to settle."
+      printBpiLog @w Debug $ "Found transaction in node, waiting" <+> pretty chainConstant <+> " blocks for it to settle."
       awaitNBlocks @w contractEnv (chainConstant + 1)
       -- Check if the tx is still present in chain-index, in case of a rollback
       -- we might not find it anymore.
@@ -292,10 +292,10 @@ writeBalancedTx contractEnv (Right tx) = do
     if signable
       then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners
       else
-        lift . printLog @w Warn . Text.unpack . Text.unlines $
+        lift . printBpiLog @w Warn . PP.vsep $
           [ "Not all required signatures have signing key files. Please sign and submit the tx manually:"
-          , "Tx file: " <> Files.txFilePath pabConf "raw" (Tx.txId tx)
-          , "Signatories (pkh): " <> Text.unwords (map pkhToText requiredSigners)
+          , "Tx file:" <+> pretty (Files.txFilePath pabConf "raw" (Tx.txId tx))
+          , "Signatories (pkh):" <+> pretty (Text.unwords (map pkhToText requiredSigners))
           ]
 
     when (not pabConf.pcDryRun && signable) $ do

src/BotPlutusInterface/Effects.hs

@@ -14,6 +14,7 @@ module BotPlutusInterface.Effects (
   uploadDir,
   updateInstanceState,
   printLog,
+  printBpiLog,
   handleContractLog,
   logToContract,
   readFileTextEnvelope,
@@ -32,6 +33,7 @@ import BotPlutusInterface.Types (
   CLILocation (..),
   ContractEnvironment,
   ContractState (ContractState),
+  LogContext (BpiLog, ContractLog),
   LogLevel (..),
   TxBudget,
   TxFile,
@@ -60,7 +62,8 @@ import Ledger qualified
 import Plutus.Contract.Effects (ChainIndexQuery, ChainIndexResponse)
 import Plutus.PAB.Core.ContractInstance.STM (Activity)
 import PlutusTx.Builtins.Internal (BuiltinByteString (BuiltinByteString))
-import Prettyprinter (Pretty (pretty), defaultLayoutOptions, layoutPretty)
+import Prettyprinter (Pretty (pretty), defaultLayoutOptions, layoutPretty, (<+>))
+import Prettyprinter qualified as PP
 import Prettyprinter.Render.String qualified as Render
 import System.Directory qualified as Directory
 import System.Exit (ExitCode (ExitFailure, ExitSuccess))
@@ -81,7 +84,7 @@ data PABEffect (w :: Type) (r :: Type) where
   CreateDirectoryIfMissing :: Bool -> FilePath -> PABEffect w ()
   -- Same as above but creates folder on the CLI machine, be that local or remote.
   CreateDirectoryIfMissingCLI :: Bool -> FilePath -> PABEffect w ()
-  PrintLog :: LogLevel -> String -> PABEffect w ()
+  PrintLog :: LogContext -> LogLevel -> PP.Doc () -> PABEffect w ()
   UpdateInstanceState :: Activity -> PABEffect w ()
   LogToContract :: (ToJSON w, Monoid w) => w -> PABEffect w ()
   ThreadDelay :: Int -> PABEffect w ()
@@ -123,7 +126,7 @@ handlePABEffect contractEnv =
           case contractEnv.cePABConfig.pcCliLocation of
             Local -> Directory.createDirectoryIfMissing createParents filePath
             Remote ipAddr -> createDirectoryIfMissingRemote ipAddr createParents filePath
-        PrintLog logLevel txt -> printLog' contractEnv.cePABConfig.pcLogLevel logLevel txt
+        PrintLog logCtx logLevel txt -> printLog' contractEnv.cePABConfig.pcLogLevel logCtx logLevel txt
         UpdateInstanceState s -> do
           atomically $
             modifyTVar contractEnv.ceContractState $
@@ -154,20 +157,25 @@ handlePABEffect contractEnv =
         SaveBudget txId exBudget -> saveBudgetImpl contractEnv txId exBudget
     )
 
-printLog' :: LogLevel -> LogLevel -> String -> IO ()
-printLog' logLevelSetting msgLogLvl msg =
-  when (logLevelSetting >= msgLogLvl) $ putStrLn msg
+printLog' :: LogLevel -> LogContext -> LogLevel -> PP.Doc () -> IO ()
+printLog' logLevelSetting msgCtx msgLogLvl msg =
+  when (logLevelSetting >= msgLogLvl) $ putStrLn target
+  where
+    target =
+      Render.renderString . layoutPretty defaultLayoutOptions $
+        pretty msgCtx <+> pretty msgLogLvl <+> msg
 
 -- | 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
 
 handleContractLogInternal :: forall w a effs. Pretty a => Eff (LogMsg a ': effs) ~> Eff (PABEffect w ': effs)
 handleContractLogInternal = reinterpret $ \case
-  LMessage msg ->
-    let msgLogLevel = toNativeLogLevel (msg ^. Freer.logLevel)
-        msgPretty = Render.renderString . layoutPretty defaultLayoutOptions . pretty $ msg
-     in printLog @w msgLogLevel msgPretty
+  LMessage logMsg ->
+    let msgContent = logMsg ^. Freer.logMessageContent
+        msgLogLevel = toNativeLogLevel (logMsg ^. Freer.logLevel)
+        msgPretty = pretty msgContent
+     in printLog @w ContractLog msgLogLevel msgPretty
   where
     toNativeLogLevel Freer.Debug = Debug
     toNativeLogLevel Freer.Info = Info
@@ -247,12 +255,21 @@ createDirectoryIfMissingCLI ::
 createDirectoryIfMissingCLI createParents path = send @(PABEffect w) $ CreateDirectoryIfMissingCLI createParents path
 
 printLog ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  LogContext ->
+  LogLevel ->
+  PP.Doc () ->
+  Eff effs ()
+printLog logCtx logLevel msg = send @(PABEffect w) $ PrintLog logCtx logLevel msg
+
+printBpiLog ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   LogLevel ->
-  String ->
+  PP.Doc () ->
   Eff effs ()
-printLog logLevel msg = send @(PABEffect w) $ PrintLog logLevel msg
+printBpiLog = printLog @w BpiLog
 
 updateInstanceState ::
   forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => Activity -> Eff effs ()

src/BotPlutusInterface/Types.hs

@@ -7,6 +7,7 @@ module BotPlutusInterface.Types (
   CLILocation (..),
   AppState (AppState),
   LogLevel (..),
+  LogContext (..),
   ContractEnvironment (..),
   Tip (Tip, epoch, hash, slot, block, era, syncProgress),
   ContractState (..),
@@ -53,6 +54,7 @@ import Plutus.PAB.Effects.Contract.Builtin (
   SomeBuiltin (SomeBuiltin),
   endpointsToSchemas,
  )
+import Prettyprinter (Pretty (pretty))
 import Servant.Client (BaseUrl (BaseUrl), Scheme (Http))
 import Wallet.Types (ContractInstanceId (..))
 import Prelude
@@ -184,7 +186,23 @@ data CLILocation = Local | Remote Text
   deriving stock (Show, Eq)
 
 data LogLevel = Error | Warn | Notice | Info | Debug
-  deriving stock (Eq, Ord, Show)
+  deriving stock (Bounded, Enum, Eq, Ord, Show)
+
+instance Pretty LogLevel where
+  pretty = \case
+    Debug -> "[DEBUG]"
+    Info -> "[INFO]"
+    Notice -> "[NOTICE]"
+    Warn -> "[WARNING]"
+    Error -> "[ERROR]"
+
+data LogContext = BpiLog | ContractLog
+  deriving stock (Bounded, Enum, Eq, Ord, Show)
+
+instance Pretty LogContext where
+  pretty = \case
+    BpiLog -> "[BPI]"
+    ContractLog -> "[CONTRACT]"
 
 instance Default PABConfig where
   def =

test/Spec/MockContract.hs

@@ -55,6 +55,7 @@ import BotPlutusInterface.Types (
   BudgetEstimationError,
   ContractEnvironment (..),
   ContractState (ContractState, csActivity, csObservableState),
+  LogContext,
   LogLevel (..),
   PABConfig (..),
   TxBudget (TxBudget),
@@ -125,6 +126,7 @@ import Plutus.PAB.Core.ContractInstance.STM (Activity (Active))
 import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential))
 import PlutusTx.Builtins (fromBuiltin)
 import PlutusTx.Builtins.Internal (BuiltinByteString (BuiltinByteString))
+import Prettyprinter qualified as PP
 import System.IO.Unsafe (unsafePerformIO)
 import Text.Read (readMaybe)
 import Wallet.Types (ContractInstanceId (ContractInstanceId))
@@ -208,7 +210,7 @@ data MockContractState w = MockContractState
   , _commandHistory :: [Text]
   , _instanceUpdateHistory :: [Activity]
   , _observableState :: w
-  , _logHistory :: [(LogLevel, String)]
+  , _logHistory :: [(LogContext, LogLevel, PP.Doc ())]
   , _contractEnv :: ContractEnvironment w
   , _utxos :: [(TxOutRef, TxOut)]
   , _tip :: Tip
@@ -292,7 +294,7 @@ runPABEffectPure initState req =
       mockCreateDirectoryIfMissing createParents filePath
     go (CreateDirectoryIfMissingCLI createParents filePath) =
       mockCreateDirectoryIfMissing createParents filePath
-    go (PrintLog logLevel msg) = mockPrintLog logLevel msg
+    go (PrintLog logCtx logLevel msg) = mockPrintLog logCtx logLevel msg
     go (UpdateInstanceState msg) = mockUpdateInstanceState msg
     go (LogToContract msg) = mockLogToContract msg
     go (ThreadDelay microseconds) = mockThreadDelay microseconds
@@ -454,9 +456,9 @@ valueToUtxoOut =
 mockCreateDirectoryIfMissing :: forall (w :: Type). Bool -> FilePath -> MockContract w ()
 mockCreateDirectoryIfMissing _ _ = pure ()
 
-mockPrintLog :: forall (w :: Type). LogLevel -> String -> MockContract w ()
-mockPrintLog logLevel msg =
-  modify @(MockContractState w) (logHistory %~ ((logLevel, msg) <|))
+mockPrintLog :: forall (w :: Type). LogContext -> LogLevel -> PP.Doc () -> MockContract w ()
+mockPrintLog logCtx logLevel msg =
+  modify @(MockContractState w) (logHistory %~ ((logCtx, logLevel, msg) <|))
 
 mockUpdateInstanceState :: forall (w :: Type). Activity -> MockContract w ()
 mockUpdateInstanceState msg =