Add setLoggerReformat

pbrisbin · pbrisbin · commit e64ad4264fb1 · 2025-02-19T11:46:19.000-05:00
This refactors the contract between `reformatTerminal` and the
construction that happens in `newLogger`.

Previously, we constructed `lReformat` directly, which is a function of
only `LogLevel` and `ByteString`. This meant that a "reformat" function
such as `reformatTerminal` had to do some extra work that all such
functions would have to do:

- Construct the `Colors` value if needed
- Return that `ByteString` as-is if it doesn't parse as `LoggedMessage`

We can pull both of these responsibilities out into `newLogger` itself
and simplify `reformatTerminal` by giving it what it needs directly.

Also, by passing `LogSettings` entirely (instead of just the
breakpoint), we've now made its signature into something that works well
as a generic "reformat" interface.

Then, by putting that logic behind a `setLoggerReformat` that
`newLogger` uses internally, we give users a hook for assign any such
"reformat" function from the outside too:

```hs
main :: IO ()
main = do
  withLoggerEnv $ \logger -&gt; do
    let app = App $ setLoggerReformat myReformat logger
    runAppM app -- ...

myReformat :: LogSettings -&gt; Colors -&gt; LogLevel -&gt; LoggedMessage -&gt; ByteString
myReformat = undefined
```

An extension like this doesn't interact with `LOG_FORMAT`, which may be
surprising, but it works well for situations that don't need to be
runtime-dynamic like that, such as CLIs.
diff --git a/Blammo/src/Blammo/Logging/Logger.hs b/Blammo/src/Blammo/Logging/Logger.hs
@@ -8,6 +8,7 @@ module Blammo.Logging.Logger
   , pushLoggerLn
   , getLoggerLogSettings
   , getLoggerReformat
+  , setLoggerReformat
   , getLoggerShouldLog
   , getLoggerShouldColor
   , pushLogStrLn
@@ -24,6 +25,7 @@ module Blammo.Logging.Logger
 
 import Prelude
 
+import Blammo.Logging.Colors (Colors, getColors)
 import Blammo.Logging.Internal.Logger
 import Blammo.Logging.LogSettings
 import Blammo.Logging.Terminal
@@ -34,9 +36,11 @@ import Control.Monad (unless, when)
 import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.Logger.Aeson
 import Control.Monad.Reader (MonadReader)
+import qualified Data.Aeson as Aeson
 import Data.ByteString (ByteString)
 import Data.Either (partitionEithers, rights)
 import Data.List (intercalate)
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import GHC.Stack (HasCallStack)
 import System.IO (stderr, stdout)
@@ -89,6 +93,17 @@ getLoggerLoggerSet = lLoggerSet
 getLoggerReformat :: Logger -> LogLevel -> ByteString -> ByteString
 getLoggerReformat = lReformat
 
+setLoggerReformat
+  :: (LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString)
+  -> Logger
+  -> Logger
+setLoggerReformat f logger =
+  logger
+    { lReformat = \level bytes -> fromMaybe bytes $ do
+        lm <- Aeson.decodeStrict bytes
+        pure $ f (lLogSettings logger) (getColors $ lShouldColor logger) level lm
+    }
+
 getLoggerShouldLog :: Logger -> LogSource -> LogLevel -> Bool
 getLoggerShouldLog = lShouldLog
 
@@ -133,18 +148,20 @@ newLogger settings = do
           <$> newFileLoggerSetN defaultBufSize concurrency path
           <*> shouldColorAuto settings (pure False)
 
-  let
-    lReformat = case getLogSettingsFormat settings of
-      LogFormatJSON -> const id -- breakpoint and color ignored
-      LogFormatTerminal -> reformatTerminal breakpoint lShouldColor
-
-    lShouldLog = shouldLogLevel settings
-    lLoggedMessages = Nothing
-    lLogSettings = settings
-
-  pure $ Logger {..}
+  let logger =
+        Logger
+          { lLogSettings = settings
+          , lLoggerSet = lLoggerSet
+          , lReformat = const id -- By default render (JSON) bytestring as-is
+          , lShouldLog = shouldLogLevel settings
+          , lShouldColor = lShouldColor
+          , lLoggedMessages = Nothing
+          }
+
+  pure $ case getLogSettingsFormat settings of
+    LogFormatJSON -> logger
+    LogFormatTerminal -> setLoggerReformat reformatTerminal logger
  where
-  breakpoint = getLogSettingsBreakpoint settings
   concurrency = getLogSettingsConcurrency settings
 
 flushLogger :: (MonadIO m, MonadReader env m, HasLogger env) => m ()
diff --git a/Blammo/src/Blammo/Logging/Terminal.hs b/Blammo/src/Blammo/Logging/Terminal.hs
@@ -20,6 +20,7 @@ module Blammo.Logging.Terminal
 import Prelude
 
 import Blammo.Logging.Colors
+import Blammo.Logging.LogSettings (LogSettings, getLogSettingsBreakpoint)
 import Blammo.Logging.Terminal.LogPiece (LogPiece, logPiece)
 import qualified Blammo.Logging.Terminal.LogPiece as LogPiece
 import Control.Monad.Logger.Aeson
@@ -28,68 +29,64 @@ import Data.Aeson.Compat (KeyMap)
 import qualified Data.Aeson.Compat as Key
 import qualified Data.Aeson.Compat as KeyMap
 import Data.ByteString (ByteString)
-import qualified Data.ByteString.Lazy as BSL
 import Data.List (sortOn)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text, pack)
 import qualified Data.Text as T
 import Data.Time (defaultTimeLocale, formatTime)
 import qualified Data.Vector as V
 
-reformatTerminal :: Int -> Bool -> LogLevel -> ByteString -> ByteString
-reformatTerminal breakpoint useColor logLevel bytes = fromMaybe bytes $ do
-  LoggedMessage {..} <- decode $ BSL.fromStrict bytes
-
-  let
-    colors@Colors {..} = getColors useColor
-
-    logTimestampPiece =
-      logPiece dim $
-        pack $
-          formatTime
-            defaultTimeLocale
-            "%F %X"
-            loggedMessageTimestamp
-
-    logLevelPiece = case logLevel of
-      LevelDebug -> logPiece gray $ padTo 9 "debug"
-      LevelInfo -> logPiece green $ padTo 9 "info"
-      LevelWarn -> logPiece yellow $ padTo 9 "warn"
-      LevelError -> logPiece red $ padTo 9 "error"
-      LevelOther x -> logPiece blue $ padTo 9 x
-
-    loggedSourceAsMap =
-      foldMap (KeyMap.singleton "source" . String) loggedMessageLogSource
-
-    logPrefixPiece =
-      logTimestampPiece <> " [" <> logLevelPiece <> "] "
-
-    logMessagePiece = logPiece bold $ padTo 31 loggedMessageText
-
-    logAttrsPiece =
-      mconcat
-        [ colorizeKeyMap " " colors loggedSourceAsMap
-        , colorizeKeyMap " " colors loggedMessageThreadContext
-        , colorizeKeyMap " " colors loggedMessageMeta
-        ]
-
-    oneLineLogPiece = mconcat [logPrefixPiece, logMessagePiece, logAttrsPiece]
-
-    multiLineLogPiece =
-      let shift = "\n" <> LogPiece.offset (LogPiece.visibleLength logPrefixPiece)
-      in  mconcat
-            [ logPrefixPiece
-            , logMessagePiece
-            , colorizeKeyMap shift colors loggedSourceAsMap
-            , colorizeKeyMap shift colors loggedMessageThreadContext
-            , colorizeKeyMap shift colors loggedMessageMeta
-            ]
-
-  pure $
-    LogPiece.bytestring $
-      if LogPiece.visibleLength oneLineLogPiece <= breakpoint
-        then oneLineLogPiece
-        else multiLineLogPiece
+reformatTerminal
+  :: LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString
+reformatTerminal settings colors@Colors {..} logLevel LoggedMessage {..} = do
+  LogPiece.bytestring $
+    if LogPiece.visibleLength oneLineLogPiece <= breakpoint
+      then oneLineLogPiece
+      else multiLineLogPiece
+ where
+  breakpoint = getLogSettingsBreakpoint settings
+
+  logTimestampPiece =
+    logPiece dim $
+      pack $
+        formatTime
+          defaultTimeLocale
+          "%F %X"
+          loggedMessageTimestamp
+
+  logLevelPiece = case logLevel of
+    LevelDebug -> logPiece gray $ padTo 9 "debug"
+    LevelInfo -> logPiece green $ padTo 9 "info"
+    LevelWarn -> logPiece yellow $ padTo 9 "warn"
+    LevelError -> logPiece red $ padTo 9 "error"
+    LevelOther x -> logPiece blue $ padTo 9 x
+
+  loggedSourceAsMap =
+    foldMap (KeyMap.singleton "source" . String) loggedMessageLogSource
+
+  logPrefixPiece =
+    logTimestampPiece <> " [" <> logLevelPiece <> "] "
+
+  logMessagePiece = logPiece bold $ padTo 31 loggedMessageText
+
+  logAttrsPiece =
+    mconcat
+      [ colorizeKeyMap " " colors loggedSourceAsMap
+      , colorizeKeyMap " " colors loggedMessageThreadContext
+      , colorizeKeyMap " " colors loggedMessageMeta
+      ]
+
+  oneLineLogPiece = mconcat [logPrefixPiece, logMessagePiece, logAttrsPiece]
+
+  multiLineLogPiece =
+    let shift = "\n" <> LogPiece.offset (LogPiece.visibleLength logPrefixPiece)
+    in  mconcat
+          [ logPrefixPiece
+          , logMessagePiece
+          , colorizeKeyMap shift colors loggedSourceAsMap
+          , colorizeKeyMap shift colors loggedMessageThreadContext
+          , colorizeKeyMap shift colors loggedMessageMeta
+          ]
 
 colorizeKeyMap :: LogPiece -> Colors -> KeyMap Value -> LogPiece
 colorizeKeyMap sep Colors {..} km
diff --git a/Blammo/tests/Blammo/Logging/TerminalSpec.hs b/Blammo/tests/Blammo/Logging/TerminalSpec.hs
