Log levels

Author: TotallyNotChase

src/BotPlutusInterface/Contract.hs

@@ -13,6 +13,7 @@ import BotPlutusInterface.Effects (
   callCommand,
   createDirectoryIfMissing,
   estimateBudget,
+  handleLogTrace',
   handlePABEffect,
   logToContract,
   printLog,
@@ -35,21 +36,20 @@ import Control.Lens (preview, (^.))
 import Control.Monad (join, void, when)
 import Control.Monad.Freer (Eff, Member, interpret, reinterpret, runM, subsume, type (~>))
 import Control.Monad.Freer.Error (runError)
-import Control.Monad.Freer.Extras.Log (handleLogTrace)
 import Control.Monad.Freer.Extras.Modify (raiseEnd)
 import Control.Monad.Freer.Writer (Writer (Tell))
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Either (EitherT, eitherT, firstEitherT, newEitherT)
-import Data.Aeson (ToJSON, Value (String, Number, Bool, Null, Array, Object))
+import Data.Aeson (ToJSON, Value (Array, Bool, Null, Number, Object, String))
 import Data.Aeson.Extras (encodeByteString)
 import Data.Either (fromRight)
+import Data.HashMap.Strict qualified as HM
 import Data.Kind (Type)
 import Data.Map qualified as Map
 import Data.Row (Row)
 import Data.Text (Text)
 import Data.Text qualified as Text
-import qualified Data.Vector as V
-import qualified Data.HashMap.Strict as HM
+import Data.Vector qualified as V
 import Ledger (POSIXTime)
 import Ledger qualified
 import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash))
@@ -72,10 +72,10 @@ import Plutus.Contract.Effects (
 import Plutus.Contract.Resumable (Resumable (..))
 import Plutus.Contract.Types (Contract (..), ContractEffs)
 import PlutusTx.Builtins (fromBuiltin)
+import Prettyprinter
+import Prettyprinter qualified as PP
 import Wallet.Emulator.Error (WalletAPIError (..))
 import Prelude
-import Prettyprinter
-import qualified Prettyprinter as PP
 
 runContract ::
   forall (w :: Type) (s :: Row Type) (e :: Type) (a :: Type).
@@ -97,7 +97,7 @@ handleContract contractEnv =
     . handleResumable contractEnv
     . handleCheckpointIgnore
     . handleWriter
-    . handleLogTrace
+    . handleLogTrace' contractEnv.cePABConfig.pcLogLevel
     . runError
     . raiseEnd
 
@@ -106,16 +106,17 @@ instance Pretty Value where
   pretty (Number n) = pretty $ show n
   pretty (Bool b) = pretty b
   pretty (Array arr) = PP.list $ pretty <$> V.toList arr
-  pretty (Object obj) = PP.group
-    . PP.encloseSep (PP.flatAlt "{ " "{") (PP.flatAlt " }" "}") ", "
-    . map
-      ( \(k, v) ->
-          PP.hang 2 $
-            PP.sep
-              [ pretty k <+> ": "
-              , pretty v
-              ]
-      )
+  pretty (Object obj) =
+    PP.group
+      . PP.encloseSep (PP.flatAlt "{ " "{") (PP.flatAlt " }" "}") ", "
+      . map
+        ( \(k, v) ->
+            PP.hang 2 $
+              PP.sep
+                [ pretty k <+> ": "
+                , pretty v
+                ]
+        )
       $ HM.toList obj
   pretty Null = "null"
 

src/BotPlutusInterface/Effects.hs

@@ -14,6 +14,7 @@ module BotPlutusInterface.Effects (
   uploadDir,
   updateInstanceState,
   printLog,
+  handleLogTrace',
   logToContract,
   readFileTextEnvelope,
   writeFileJSON,
@@ -40,8 +41,11 @@ import Cardano.Api (AsType, FileError (FileIOError), HasTextEnvelope, TextEnvelo
 import Cardano.Api qualified
 import Control.Concurrent qualified as Concurrent
 import Control.Concurrent.STM (atomically, modifyTVar, modifyTVar')
+import Control.Lens
 import Control.Monad (void, when)
-import Control.Monad.Freer (Eff, LastMember, Member, interpretM, send, type (~>))
+import Control.Monad.Freer (Eff, LastMember, Member, interpret, interpretM, send, type (~>))
+import Control.Monad.Freer.Extras (LogMsg (LMessage))
+import Control.Monad.Freer.Extras qualified as Freer
 import Control.Monad.Trans.Except.Extra (handleIOExceptT, runExceptT)
 import Data.Aeson (ToJSON)
 import Data.Aeson qualified as JSON
@@ -52,10 +56,13 @@ import Data.Maybe (catMaybes)
 import Data.String (IsString, fromString)
 import Data.Text (Text)
 import Data.Text qualified as Text
+import Debug.Trace qualified as Trace
 import Ledger qualified
 import Plutus.Contract.Effects (ChainIndexQuery, ChainIndexResponse)
 import Plutus.PAB.Core.ContractInstance.STM (Activity)
 import PlutusTx.Builtins.Internal (BuiltinByteString (BuiltinByteString))
+import Prettyprinter
+import Prettyprinter.Render.String qualified as Render
 import System.Directory qualified as Directory
 import System.Exit (ExitCode (ExitFailure, ExitSuccess))
 import System.Process (readProcess, readProcessWithExitCode)
@@ -152,6 +159,23 @@ printLog' :: LogLevel -> LogLevel -> String -> IO ()
 printLog' logLevelSetting msgLogLvl msg =
   when (logLevelSetting >= msgLogLvl) $ putStrLn msg
 
+-- | Version of "Control.Monad.Freer.Extras.handleLogTrace" that takes into account the log level setting.
+handleLogTrace' :: Pretty a => LogLevel -> Eff (LogMsg a ': effs) ~> Eff effs
+handleLogTrace' logLevelSetting = interpret $ \case
+  LMessage msg ->
+    if logLevelSetting >= toNativeLogLevel (msg ^. Freer.logLevel)
+      then Trace.trace (Render.renderString . layoutPretty defaultLayoutOptions . pretty $ msg) $ pure ()
+      else pure ()
+  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
+
 callLocalCommand :: forall (a :: Type). ShellArgs a -> IO (Either Text a)
 callLocalCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} =
   second cmdOutParser <$> readProcessEither (Text.unpack cmdName) (map Text.unpack cmdArgs)