Coloring

herp-logger.cabal

@@ -18,6 +18,7 @@ library
       Herp.Logger.SentryTransport
       Herp.Logger.StdoutTransport
       Herp.Logger.Transport
+      Herp.Logger.ANSI.Coloring
   hs-source-dirs:
       src
   default-extensions:
@@ -69,9 +70,11 @@ library
       ImportQualifiedPost
   build-depends:
       aeson
+    , ansi-terminal
     , async
     , base >=4.7 && <5
     , bytestring
+    , colour
     , fast-logger
     , generic-data
     , monad-logger

src/Herp/Logger/ANSI/Coloring.hs

@@ -0,0 +1,30 @@
+module Herp.Logger.ANSI.Coloring where
+
+import Data.Colour.SRGB
+import Data.String
+import Herp.Logger.LogLevel (LogLevel (..))
+import System.Console.ANSI
+
+-- https://hackage.haskell.org/package/ansi-terminal-0.11.3/docs/System-Console-ANSI-Types.html#t:SGR
+
+logLevelToSGR :: LogLevel -> [SGR]
+logLevelToSGR level = case level of
+    Debug -> [SetRGBColor Background $ sRGB24 196 196 196] -- Grey
+    Informational -> [SetRGBColor Background $ sRGB24 155 204 228] -- Light blue
+    Notice -> [SetRGBColor Background $ sRGB24 154 169 186] -- Grey
+    Warning -> [SetRGBColor Background $ sRGB24 237 179 89] -- Orange
+    Error -> [SetRGBColor Background $ sRGB24 226 86 77] -- Red
+    Critical -> [SetRGBColor Background $ sRGB24 202 9 10] -- Wine red
+    Alert -> [SetRGBColor Background $ sRGB24 152 0 0] -- #980000
+    Emergency -> [SetRGBColor Background $ sRGB24 101 0 0] --- #650000
+
+setLogColorStr :: IsString a => LogLevel -> a
+setLogColorStr level =
+    let sgrLogInfo = logLevelToSGR level
+     in fromString (setSGRCode sgrLogInfo)
+
+resetLogColorStr :: IsString a => a
+resetLogColorStr = fromString (setSGRCode [Reset])
+
+coloringLogInfoStr :: (IsString a, Semigroup a) => LogLevel -> a -> a
+coloringLogInfoStr level str = setLogColorStr level <> " " <> resetLogColorStr <> " " <> str

src/Herp/Logger/StdoutTransport.hs

@@ -1,15 +1,21 @@
 {-# LANGUAGE CPP #-}
-module Herp.Logger.StdoutTransport where
 
-import "fast-logger" System.Log.FastLogger (LoggerSet, ToLogStr(toLogStr), pushLogStrLn, flushLogStr)
-import Herp.Logger.Transport
+module Herp.Logger.StdoutTransport (
+    stdoutTransport,
+    stdoutANSITransport,
+) where
+
 import Herp.Logger.LogLevel
+import Herp.Logger.Transport
+import "fast-logger" System.Log.FastLogger (LoggerSet, ToLogStr (toLogStr), flushLogStr, pushLogStrLn)
 
 import "aeson" Data.Aeson ((.=))
 import "aeson" Data.Aeson qualified as A
 import "aeson" Data.Aeson.Encoding qualified as A
 import Data.ByteString.Short qualified as SB
+import Data.Text (Text)
 import Data.Text.Encoding qualified as T
+import Herp.Logger.ANSI.Coloring (coloringLogInfoStr)
 
 #if MIN_VERSION_aeson(2,0,0)
 import "aeson" Data.Aeson.Key (fromText)
@@ -21,22 +27,39 @@ fromText :: Text -> Text
 fromText = id
 #endif
 
-stdoutTransport :: LoggerSet -> LogLevel -> Transport
-stdoutTransport loggerSet transportThreshold =
-    let name = "stdout"
-        runTransport TransportInput { message, date, level, extra } = do
-            let series =
-                    ( "level" .= level
-                    <> "date" .= T.decodeUtf8 (SB.fromShort date)
-                    <> "message" .= message
-                    )
-            let value = A.pairs $ series <> foldMap (uncurry (.=)) (KM.toList extra)
-            let json = A.encodingToLazyByteString value
-            pushLogStrLn loggerSet $ toLogStr json
+stdoutTransport' :: Text -> (LoggerSet -> TransportInput -> IO ()) -> LoggerSet -> LogLevel -> Transport
+stdoutTransport' name push loggerSet transportThreshold =
+    let runTransport input = push loggerSet input
         flush = flushLogStr loggerSet
     in Transport
         { name = name
         , threshold = transportThreshold
         , runTransport = runTransport
         , flush
         }
+
+convertTransportInputToEncoding :: TransportInput -> A.Encoding
+convertTransportInputToEncoding
+    TransportInput{message, date, level, extra} =
+        let series =
+                ( "level" .= level
+                    <> "date" .= T.decodeUtf8 (SB.fromShort date)
+                    <> "message" .= message
+                )
+         in A.pairs $ series <> foldMap (uncurry (.=)) (KM.toList extra)
+
+stdoutTransport :: LoggerSet -> LogLevel -> Transport
+stdoutTransport = stdoutTransport' "stdout" push
+  where
+    push loggerSet input =
+        let value = convertTransportInputToEncoding input
+            json = A.encodingToLazyByteString value
+         in pushLogStrLn loggerSet (toLogStr json)
+
+stdoutANSITransport :: LoggerSet -> LogLevel -> Transport
+stdoutANSITransport = stdoutTransport' "stdoutANSI" push
+  where
+    push loggerSet input@TransportInput{level} =
+        let value = convertTransportInputToEncoding input
+            json = A.encodingToLazyByteString value
+         in pushLogStrLn loggerSet (toLogStr $ coloringLogInfoStr level json)

tests/stdout.hs

@@ -11,8 +11,8 @@ import Herp.Logger as Logger
 import Herp.Logger.StdoutTransport
 import System.Log.FastLogger.LoggerSet as LS
 
-loggerLevelTest loggerSet lv = do
-    logger <- Logger.new 1 lv [stdoutTransport loggerSet Debug]
+loggerLevelTest loggerSet transports lv = do
+    logger <- Logger.new 1 lv transports
 
     flip runReaderT logger $ do
         logM [ #debug, "debug" ]
@@ -23,10 +23,11 @@ loggerLevelTest loggerSet lv = do
         logM [ #crit, "lorem ipsum" ]
         logM [ #alert, "lorem ipsum" ]
         logM [ #emerg, "lorem ipsum" ]
-    
+
     loggerCleanup logger
 
 main :: IO ()
 main = bracket (LS.newStdoutLoggerSet 4096) LS.rmLoggerSet $ \loggerSet -> do
-    loggerLevelTest loggerSet Debug
-    loggerLevelTest loggerSet Informational
+    loggerLevelTest loggerSet [stdoutTransport loggerSet Debug] Debug
+    loggerLevelTest loggerSet [stdoutTransport loggerSet Debug] Informational
+    loggerLevelTest loggerSet [stdoutANSITransport loggerSet Debug] Debug