diff --git a/Blammo.cabal b/Blammo.cabal --- a/Blammo.cabal +++ b/Blammo.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: Blammo -version: 2.1.1.0 +version: 2.1.2.0 license: MIT license-file: LICENSE maintainer: Freckle Education diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,10 @@ -## [_Unreleased_](https://github.com/freckle/blammo/compare/Blammo-v2.1.1.0...main) +## [_Unreleased_](https://github.com/freckle/blammo/compare/Blammo-v2.1.2.0...main) -## [v2.1.1.0](https://github.com/freckle/blammo/compare/v2.0.0.0...Blammo-v2.1.0.0) +## [v2.1.2.0](https://github.com/freckle/blammo/compare/v2.1.1.0...Blammo-v2.1.2.0) + +- Add `setLoggerReformat` + +## [v2.1.1.0](https://github.com/freckle/blammo/compare/v2.1.0.0...Blammo-v2.1.1.0) - Accept special value `null` for `LOG_DESTINATION` as a synonym for the null device (`/dev/null` or `\\.\NUL` on windows). diff --git a/src/Blammo/Logging/LogSettings/Env.hs b/src/Blammo/Logging/LogSettings/Env.hs --- a/src/Blammo/Logging/LogSettings/Env.hs +++ b/src/Blammo/Logging/LogSettings/Env.hs @@ -74,7 +74,7 @@ parserWith :: LogSettings -> Parser Error LogSettings parserWith defaults = - ($ defaults) . appEndo . mconcat + flip (appEndo . mconcat) defaults <$> sequenceA [ endoVar readLogLevels setLogSettingsLevels "LOG_LEVEL" , endoVar readLogDestination setLogSettingsDestination "LOG_DESTINATION" diff --git a/src/Blammo/Logging/Logger.hs b/src/Blammo/Logging/Logger.hs --- a/src/Blammo/Logging/Logger.hs +++ b/src/Blammo/Logging/Logger.hs @@ -8,6 +8,7 @@ , pushLoggerLn , getLoggerLogSettings , getLoggerReformat + , setLoggerReformat , getLoggerShouldLog , getLoggerShouldColor , pushLogStrLn @@ -24,6 +25,7 @@ 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.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 @@ 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 @@ <$> 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 + 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 $ Logger {..} + 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/src/Blammo/Logging/Terminal.hs b/src/Blammo/Logging/Terminal.hs --- a/src/Blammo/Logging/Terminal.hs +++ b/src/Blammo/Logging/Terminal.hs @@ -20,6 +20,7 @@ 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,7 +29,6 @@ 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) @@ -36,60 +36,57 @@ 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 +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 - 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 + logTimestampPiece = + logPiece dim $ + pack $ + formatTime + defaultTimeLocale + "%F %X" + loggedMessageTimestamp - loggedSourceAsMap = - foldMap (KeyMap.singleton "source" . String) loggedMessageLogSource + 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 - logPrefixPiece = - logTimestampPiece <> " [" <> logLevelPiece <> "] " + loggedSourceAsMap = + foldMap (KeyMap.singleton "source" . String) loggedMessageLogSource - logMessagePiece = logPiece bold $ padTo 31 loggedMessageText + logPrefixPiece = + logTimestampPiece <> " [" <> logLevelPiece <> "] " - logAttrsPiece = - mconcat - [ colorizeKeyMap " " colors loggedSourceAsMap - , colorizeKeyMap " " colors loggedMessageThreadContext - , colorizeKeyMap " " colors loggedMessageMeta - ] + logMessagePiece = logPiece bold $ padTo 31 loggedMessageText - oneLineLogPiece = mconcat [logPrefixPiece, logMessagePiece, logAttrsPiece] + logAttrsPiece = + mconcat + [ colorizeKeyMap " " colors loggedSourceAsMap + , colorizeKeyMap " " colors loggedMessageThreadContext + , colorizeKeyMap " " colors loggedMessageMeta + ] - 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 - ] + oneLineLogPiece = mconcat [logPrefixPiece, logMessagePiece, logAttrsPiece] - pure $ - LogPiece.bytestring $ - if LogPiece.visibleLength oneLineLogPiece <= breakpoint - then oneLineLogPiece - else multiLineLogPiece + 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/tests/Blammo/Logging/TerminalSpec.hs b/tests/Blammo/Logging/TerminalSpec.hs --- a/tests/Blammo/Logging/TerminalSpec.hs +++ b/tests/Blammo/Logging/TerminalSpec.hs @@ -7,14 +7,19 @@ import Prelude import Blammo.Logging +import Blammo.Logging.Colors (noColors) +import Blammo.Logging.LogSettings + ( LogSettings + , defaultLogSettings + , setLogSettingsBreakpoint + ) import Blammo.Logging.Logger (LoggedMessage (..)) import Blammo.Logging.Terminal -import Data.Aeson (encode, object) +import Data.Aeson (object) import Data.Aeson.Types (Object, Pair, Value (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BSL import Data.Text (Text) import Data.Time import Test.Hspec @@ -22,35 +27,22 @@ spec :: Spec spec = do describe "reformatTerminal" $ do - it "passes-through none-LoggedMessages as-is" $ do - let - bs :: ByteString - bs = "I'm not even JSON" - - bsJSON :: ByteString - bsJSON = "{\"I'm\":\"Valid JSON, but not LoggedMessage\"}" - - reformatTerminal 0 False LevelInfo bs `shouldBe` bs - reformatTerminal 0 False LevelInfo bsJSON `shouldBe` bsJSON - it "reformats LoggedMessages with complex attributes" $ do let - bs = - BSL.toStrict $ - encode - LoggedMessage - { loggedMessageTimestamp = - UTCTime - { utctDay = fromGregorian 2022 1 1 - , utctDayTime = 0 - } - , loggedMessageLevel = LevelInfo - , loggedMessageLoc = Nothing - , loggedMessageLogSource = Just "app" - , loggedMessageThreadContext = keyMap ["x" .= object ["y" .= True]] - , loggedMessageText = "I'm a log message" - , loggedMessageMeta = keyMap ["a" .= [1 :: Int, 2, 3]] - } + lm = + LoggedMessage + { loggedMessageTimestamp = + UTCTime + { utctDay = fromGregorian 2022 1 1 + , utctDayTime = 0 + } + , loggedMessageLevel = LevelInfo + , loggedMessageLoc = Nothing + , loggedMessageLogSource = Just "app" + , loggedMessageThreadContext = keyMap ["x" .= object ["y" .= True]] + , loggedMessageText = "I'm a log message" + , loggedMessageMeta = keyMap ["a" .= [1 :: Int, 2, 3]] + } expected = mconcat @@ -58,32 +50,30 @@ , " source=app x={y: True} a=[1, 2, 3]" ] - reformatTerminal 120 False LevelInfo bs `shouldBe` expected + reformatTerminal (settings 120) noColors LevelInfo lm `shouldBe` expected it "moves attributes to multi-line at the given breakpoint" $ do let - bs = - BSL.toStrict $ - encode - LoggedMessage - { loggedMessageTimestamp = - UTCTime - { utctDay = fromGregorian 2022 1 1 - , utctDayTime = 0 - } - , loggedMessageLevel = LevelInfo - , loggedMessageLoc = Nothing - , loggedMessageLogSource = Just "app" - , loggedMessageThreadContext = mempty - , loggedMessageText = "I'm a log message" - , loggedMessageMeta = - keyMap - [ "a" .= ("aaaaaaaaa" :: Text) - , "b" .= ("aaaaaaaaa" :: Text) - , "c" .= ("aaaaaaaaa" :: Text) - , "d" .= ("aaaaaaaaa" :: Text) - ] - } + lm = + LoggedMessage + { loggedMessageTimestamp = + UTCTime + { utctDay = fromGregorian 2022 1 1 + , utctDayTime = 0 + } + , loggedMessageLevel = LevelInfo + , loggedMessageLoc = Nothing + , loggedMessageLogSource = Just "app" + , loggedMessageThreadContext = mempty + , loggedMessageText = "I'm a log message" + , loggedMessageMeta = + keyMap + [ "a" .= ("aaaaaaaaa" :: Text) + , "b" .= ("aaaaaaaaa" :: Text) + , "c" .= ("aaaaaaaaa" :: Text) + , "d" .= ("aaaaaaaaa" :: Text) + ] + } single = mconcat @@ -103,33 +93,32 @@ breakpoint = BS.length single - reformatTerminal breakpoint False LevelInfo bs `shouldBe` single - reformatTerminal (breakpoint - 1) False LevelInfo bs `shouldBe` multi + reformatTerminal (settings breakpoint) noColors LevelInfo lm `shouldBe` single + reformatTerminal (settings $ breakpoint - 1) noColors LevelInfo lm + `shouldBe` multi it "aligns multi-line correctly even with color escapes" $ do let - bs = - BSL.toStrict $ - encode - LoggedMessage - { loggedMessageTimestamp = - UTCTime - { utctDay = fromGregorian 2022 1 1 - , utctDayTime = 0 - } - , loggedMessageLevel = LevelInfo - , loggedMessageLoc = Nothing - , loggedMessageLogSource = Just "app" - , loggedMessageThreadContext = mempty - , loggedMessageText = "I'm a log message" - , loggedMessageMeta = - keyMap - [ "a" .= ("aaaaaaaaa" :: Text) - , "b" .= ("aaaaaaaaa" :: Text) - , "c" .= ("aaaaaaaaa" :: Text) - , "d" .= ("aaaaaaaaa" :: Text) - ] - } + lm = + LoggedMessage + { loggedMessageTimestamp = + UTCTime + { utctDay = fromGregorian 2022 1 1 + , utctDayTime = 0 + } + , loggedMessageLevel = LevelInfo + , loggedMessageLoc = Nothing + , loggedMessageLogSource = Just "app" + , loggedMessageThreadContext = mempty + , loggedMessageText = "I'm a log message" + , loggedMessageMeta = + keyMap + [ "a" .= ("aaaaaaaaa" :: Text) + , "b" .= ("aaaaaaaaa" :: Text) + , "c" .= ("aaaaaaaaa" :: Text) + , "d" .= ("aaaaaaaaa" :: Text) + ] + } expected = mconcat @@ -141,7 +130,11 @@ , " d=aaaaaaaaa" ] - stripColor (reformatTerminal 120 True LevelInfo bs) `shouldBe` expected + stripColor (reformatTerminal (settings 120) noColors LevelInfo lm) + `shouldBe` expected + +settings :: Int -> LogSettings +settings breakpoint = setLogSettingsBreakpoint breakpoint defaultLogSettings keyMap :: [Pair] -> Object keyMap ps = km where Object km = object ps