Merge pull request #134 from mlabs-haskell/improve-logging

improve logging

Author: IAmPara0x

src/BotPlutusInterface/Balance.hs

@@ -23,7 +23,14 @@ import BotPlutusInterface.Effects (
  )
 import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
 import BotPlutusInterface.Files qualified as Files
-import BotPlutusInterface.Types (CollateralUtxo, LogLevel (Debug), PABConfig, collateralTxOutRef)
+import BotPlutusInterface.Types (
+  CollateralUtxo (collateralTxOutRef),
+  LogLevel (Debug),
+  LogType (TxBalancingLog),
+  PABConfig,
+  collateralTxOutRef,
+ )
+
 import Cardano.Api (ExecutionUnitPrices (ExecutionUnitPrices))
 import Cardano.Api.Shelley (ProtocolParameters (protocolParamPrices))
 import Control.Monad (foldM, void, zipWithM)
@@ -121,7 +128,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
           requiredSigs :: [PubKeyHash]
           requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx)
 
-      lift $ printBpiLog @w Debug $ viaShow utxoIndex
+      lift $ printBpiLog @w (Debug [TxBalancingLog]) $ viaShow utxoIndex
 
       -- We need this folder on the CLI machine, which may not be the local machine
       lift $ createDirectoryIfMissingCLI @w False (Text.unpack "pcTxFileDir")
@@ -182,7 +189,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
 
       let minUtxos = prevMinUtxos ++ nextMinUtxos
 
-      lift $ printBpiLog @w Debug $ "Min utxos:" <+> pretty minUtxos
+      lift $ printBpiLog @w (Debug [TxBalancingLog]) $ "Min utxos:" <+> pretty minUtxos
 
       -- Calculate fees by pre-balancing the tx, building it, and running the CLI on result
       txWithoutFees <-
@@ -194,7 +201,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
 
       let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget
 
-      lift $ printBpiLog @w Debug $ "Fees:" <+> pretty fees
+      lift $ printBpiLog @w (Debug [TxBalancingLog]) $ "Fees:" <+> pretty fees
 
       -- Rebalance the initial tx with the above fees
       balancedTx <- hoistEither $ balanceTxStep balanceCfg minUtxos utxoIndex changeAddr $ tx `withFee` fees

src/BotPlutusInterface/Config.hs

@@ -17,6 +17,7 @@ import BotPlutusInterface.Effects (
 import BotPlutusInterface.Types (
   CLILocation (..),
   LogLevel (..),
+  LogType (AnyLog),
   PABConfig (..),
   TxStatusPolling (TxStatusPolling, spBlocksTimeOut, spInterval),
  )
@@ -75,11 +76,11 @@ instance ToValue LogLevel where
 
 logLevelSpec :: ValueSpec LogLevel
 logLevelSpec =
-  Error <$ atomSpec "error"
-    <!> Warn <$ atomSpec "warn"
-    <!> Notice <$ atomSpec "notice"
-    <!> Info <$ atomSpec "info"
-    <!> Debug <$ atomSpec "debug"
+  Error [AnyLog] <$ atomSpec "error"
+    <!> Warn [AnyLog] <$ atomSpec "warn"
+    <!> Notice [AnyLog] <$ atomSpec "notice"
+    <!> Info [AnyLog] <$ atomSpec "info"
+    <!> Debug [AnyLog] <$ atomSpec "debug"
 
 instance ToValue TxStatusPolling where
   toValue (TxStatusPolling interval timeout) =

src/BotPlutusInterface/Contract.hs

@@ -35,6 +35,7 @@ import BotPlutusInterface.Types (
   CollateralUtxo (CollateralUtxo),
   ContractEnvironment (..),
   LogLevel (Debug, Notice, Warn),
+  LogType (CollateralLog, PABLog),
   Tip (block, slot),
   TxFile (Signed),
   collateralValue,
@@ -174,7 +175,7 @@ handlePABReq ::
   PABReq ->
   Eff effs PABResp
 handlePABReq contractEnv req = do
-  printBpiLog @w Debug $ pretty req
+  printBpiLog @w (Debug [PABLog]) $ pretty req
   resp <- case req of
     ----------------------
     -- Handled requests --
@@ -208,7 +209,7 @@ handlePABReq contractEnv req = do
     -- YieldUnbalancedTxReq UnbalancedTx
     unsupported -> error ("Unsupported PAB effect: " ++ show unsupported)
 
-  printBpiLog @w Debug $ pretty resp
+  printBpiLog @w (Debug [PABLog]) $ pretty resp
   pure resp
 
 {- | Await till transaction status change to something from `Unknown`.
@@ -227,7 +228,7 @@ awaitTxStatusChange ::
   Eff effs TxStatus
 awaitTxStatusChange contractEnv txId = do
   checkStartedBlock <- currentBlock contractEnv
-  printBpiLog @w Debug $ pretty $ "Awaiting status change for " ++ show txId
+  printBpiLog @w (Debug [PABLog]) $ pretty $ "Awaiting status change for " ++ show txId
 
   let txStatusPolling = contractEnv.cePABConfig.pcTxStatusPolling
       pollInterval = fromIntegral $ txStatusPolling.spInterval
@@ -276,7 +277,7 @@ awaitTxStatusChange contractEnv txId = do
           pure . Just $ fromTx blk tx
         Nothing -> pure Nothing
 
-    logDebug = printBpiLog @w Debug . pretty
+    logDebug = printBpiLog @w (Debug [PABLog]) . pretty
 
 -- | This will FULLY balance a transaction
 balanceTx ::
@@ -339,7 +340,7 @@ writeBalancedTx contractEnv (Right tx) = do
     if signable
       then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners
       else
-        lift . printBpiLog @w Warn . PP.vsep $
+        lift . printBpiLog @w (Warn [PABLog]) . PP.vsep $
           [ "Not all required signatures have signing key files. Please sign and submit the tx manually:"
           , "Tx file:" <+> pretty (Files.txFilePath pabConf "raw" (Tx.txId tx))
           , "Signatories (pkh):" <+> pretty (Text.unwords (map pkhToText requiredSigners))
@@ -477,12 +478,12 @@ handleCollateral cEnv = do
   case result of
     Right collteralUtxo ->
       setInMemCollateral @w collteralUtxo
-        >> Right <$> printBpiLog @w Debug "successfully set the collateral utxo in env."
+        >> Right <$> printBpiLog @w (Debug [CollateralLog]) "successfully set the collateral utxo in env."
     Left err -> pure $ Left $ "Failed to make collateral: " <> err
   where
     --
     helperLog :: PP.Doc () -> ExceptT CollateralUtxo (Eff effs) ()
-    helperLog msg = newEitherT $ Right <$> printBpiLog @w Debug msg
+    helperLog msg = newEitherT $ Right <$> printBpiLog @w (Debug [CollateralLog]) msg
 
 {- | Create collateral UTxO by submitting Tx.
   Then try to find created UTxO at own PKH address.
@@ -493,7 +494,7 @@ makeCollateral ::
   ContractEnvironment w ->
   Eff effs (Either Text CollateralUtxo)
 makeCollateral cEnv = runEitherT $ do
-  lift $ printBpiLog @w Notice "Making collateral"
+  lift $ printBpiLog @w (Notice [CollateralLog]) "Making collateral"
 
   let pabConf = cEnv.cePABConfig
   unbalancedTx <-
@@ -512,7 +513,7 @@ makeCollateral cEnv = runEitherT $ do
     WriteBalancedTxFailed e -> throwE . T.pack $ "Failed to create collateral output: " <> show e
     WriteBalancedTxSuccess cTx -> do
       status <- lift $ awaitTxStatusChange cEnv (getCardanoTxId cTx)
-      lift $ printBpiLog @w Notice $ "Collateral Tx Status: " <> pretty status
+      lift $ printBpiLog @w (Notice [CollateralLog]) $ "Collateral Tx Status: " <> pretty status
       newEitherT $ findCollateralAtOwnPKH cEnv
 
 -- | Finds a collateral present at user's address

src/BotPlutusInterface/Effects.hs

@@ -44,6 +44,7 @@ import BotPlutusInterface.Types (
   ContractState (ContractState),
   LogContext (BpiLog, ContractLog),
   LogLevel (..),
+  LogType (..),
   LogsList (LogsList),
   TxBudget,
   TxFile,
@@ -64,6 +65,7 @@ import Data.Aeson qualified as JSON
 import Data.Bifunctor (second)
 import Data.ByteString qualified as ByteString
 import Data.Kind (Type)
+import Data.List (intersect)
 import Data.Maybe (catMaybes)
 import Data.String (IsString, fromString)
 import Data.Text (Text)
@@ -191,12 +193,18 @@ handlePABEffect contractEnv =
 
 printLog' :: LogLevel -> LogContext -> LogLevel -> PP.Doc () -> IO ()
 printLog' logLevelSetting msgCtx msgLogLvl msg =
-  when (logLevelSetting >= msgLogLvl) $ putStrLn target
+  when
+    ( logLevelSetting {ltLogTypes = mempty} >= msgLogLvl {ltLogTypes = mempty}
+        && not (null intersectLogTypes)
+    )
+    $ putStrLn target
   where
     target =
       Render.renderString . layoutPretty defaultLayoutOptions $
         prettyLog msgCtx msgLogLvl msg
 
+    intersectLogTypes = ltLogTypes logLevelSetting `intersect` (ltLogTypes msgLogLvl <> [AnyLog])
+
 prettyLog :: LogContext -> LogLevel -> PP.Doc () -> PP.Doc ()
 prettyLog msgCtx msgLogLvl msg = pretty msgCtx <+> pretty msgLogLvl <+> msg
 
@@ -217,14 +225,14 @@ handleContractLogInternal = reinterpret $ \case
         msgPretty = pretty msgContent
      in printLog @w ContractLog msgLogLevel msgPretty
   where
-    toNativeLogLevel Freer.Debug = Debug
-    toNativeLogLevel Freer.Info = Info
-    toNativeLogLevel Freer.Notice = Notice
-    toNativeLogLevel Freer.Warning = Warn
-    toNativeLogLevel Freer.Error = Error
-    toNativeLogLevel Freer.Critical = Error
-    toNativeLogLevel Freer.Alert = Error
-    toNativeLogLevel Freer.Emergency = Error
+    toNativeLogLevel Freer.Debug = Debug [AnyLog]
+    toNativeLogLevel Freer.Info = Info [AnyLog]
+    toNativeLogLevel Freer.Notice = Notice [AnyLog]
+    toNativeLogLevel Freer.Warning = Warn [AnyLog]
+    toNativeLogLevel Freer.Error = Error [AnyLog]
+    toNativeLogLevel Freer.Critical = Error [AnyLog]
+    toNativeLogLevel Freer.Alert = Error [AnyLog]
+    toNativeLogLevel Freer.Emergency = Error [AnyLog]
 
 callLocalCommand :: forall (a :: Type). ShellArgs a -> IO (Either Text a)
 callLocalCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} =

src/BotPlutusInterface/Types.hs

@@ -6,8 +6,9 @@ module BotPlutusInterface.Types (
   PABConfig (..),
   CLILocation (..),
   AppState (AppState),
-  LogLevel (..),
   LogContext (..),
+  LogLevel (..),
+  LogType (..),
   ContractEnvironment (..),
   Tip (Tip, epoch, hash, slot, block, era, syncProgress),
   ContractState (..),
@@ -245,16 +246,36 @@ data ContractState w = ContractState
 data CLILocation = Local | Remote Text
   deriving stock (Show, Eq)
 
-data LogLevel = Error | Warn | Notice | Info | Debug
-  deriving stock (Bounded, Enum, Eq, Ord, Show)
+data LogType
+  = CoinSelectionLog
+  | TxBalancingLog
+  | CollateralLog
+  | PABLog
+  | AnyLog
+  deriving stock (Eq, Ord, Show)
+
+instance Pretty LogType where
+  pretty CoinSelectionLog = "CoinSelection"
+  pretty TxBalancingLog = "TxBalancing"
+  pretty CollateralLog = "Collateral"
+  pretty PABLog = "PABLog"
+  pretty AnyLog = "Any"
+
+data LogLevel
+  = Error {ltLogTypes :: [LogType]}
+  | Warn {ltLogTypes :: [LogType]}
+  | Notice {ltLogTypes :: [LogType]}
+  | Info {ltLogTypes :: [LogType]}
+  | Debug {ltLogTypes :: [LogType]}
+  deriving stock (Eq, Ord, Show)
 
 instance Pretty LogLevel where
   pretty = \case
-    Debug -> "[DEBUG]"
-    Info -> "[INFO]"
-    Notice -> "[NOTICE]"
-    Warn -> "[WARNING]"
-    Error -> "[ERROR]"
+    Debug a -> "[DEBUG " <> pretty a <> "]"
+    Info a -> "[INFO " <> pretty a <> "]"
+    Notice a -> "[NOTICE " <> pretty a <> "]"
+    Warn a -> "[WARNING " <> pretty a <> "]"
+    Error a -> "[ERROR " <> pretty a <> "]"
 
 data LogContext = BpiLog | ContractLog
   deriving stock (Bounded, Enum, Eq, Ord, Show)
@@ -278,7 +299,7 @@ instance Default PABConfig where
       , pcMetadataDir = "/metadata"
       , pcDryRun = True
       , pcProtocolParamsFile = "./protocol.json"
-      , pcLogLevel = Info
+      , pcLogLevel = Info [AnyLog]
       , pcOwnPubKeyHash = ""
       , pcOwnStakePubKeyHash = Nothing
       , pcPort = 9080

test/Spec/BotPlutusInterface/Config.hs

@@ -3,7 +3,13 @@
 module Spec.BotPlutusInterface.Config (tests) where
 
 import BotPlutusInterface.Config (loadPABConfig, savePABConfig)
-import BotPlutusInterface.Types (CLILocation (..), LogLevel (..), PABConfig (..), TxStatusPolling (TxStatusPolling))
+import BotPlutusInterface.Types (
+  CLILocation (..),
+  LogLevel (..),
+  LogType (AnyLog),
+  PABConfig (..),
+  TxStatusPolling (TxStatusPolling),
+ )
 import Cardano.Api (
   AnyPlutusScriptVersion (..),
   CostModel (..),
@@ -107,7 +113,7 @@ pabConfigExample =
     , pcMetadataDir = "path"
     , pcDryRun = False
     , pcProtocolParamsFile = "./protocol.json3"
-    , pcLogLevel = Debug
+    , pcLogLevel = Debug [AnyLog]
     , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546"
     , pcOwnStakePubKeyHash = Just $ StakePubKeyHash "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97547"
     , pcPort = 1021