From 5f5c1d518312cefa033a8af67e104cac726b8d88 Mon Sep 17 00:00:00 2001 From: ccycle Date: Tue, 9 Aug 2022 19:35:11 +0900 Subject: [PATCH 1/8] Add modules related to `ansi-terminal` --- herp-logger.cabal | 3 ++ src/Herp/Logger/ANSI/Coloring.hs | 33 +++++++++++++++++++ src/Herp/Logger/StdoutANSITransport.hs | 45 ++++++++++++++++++++++++++ 3 files changed, 81 insertions(+) create mode 100644 src/Herp/Logger/ANSI/Coloring.hs create mode 100644 src/Herp/Logger/StdoutANSITransport.hs diff --git a/herp-logger.cabal b/herp-logger.cabal index 3840361..dd4132a 100644 --- a/herp-logger.cabal +++ b/herp-logger.cabal @@ -18,6 +18,8 @@ library Herp.Logger.SentryTransport Herp.Logger.StdoutTransport Herp.Logger.Transport + Herp.Logger.ANSI.Coloring + Herp.Logger.StdoutANSITransport hs-source-dirs: src default-extensions: @@ -69,6 +71,7 @@ library ImportQualifiedPost build-depends: aeson + , ansi-terminal , async , base >=4.7 && <5 , bytestring diff --git a/src/Herp/Logger/ANSI/Coloring.hs b/src/Herp/Logger/ANSI/Coloring.hs new file mode 100644 index 0000000..ecb5570 --- /dev/null +++ b/src/Herp/Logger/ANSI/Coloring.hs @@ -0,0 +1,33 @@ +module Herp.Logger.ANSI.Coloring ( + module Herp.Logger.ANSI.Coloring, + module System.Console.ANSI +) + where + +import Herp.Logger.LogLevel (LogLevel (..)) +import System.Console.ANSI + +-- import System.Console.ANSIhttps://hackage.haskell.org/package/ansi-terminal-0.11.3/docs/System-Console-ANSI-Types.html#t:SGR +data SGRLogInfo = NotColored | SGRLogInfo SGR + +logLevelToColoredLogInfo :: LogLevel -> SGRLogInfo +logLevelToColoredLogInfo level = case level of + Debug -> SGRLogInfo $ SetColor Foreground Dull Blue + Informational -> NotColored + Notice -> SGRLogInfo $ SetColor Foreground Dull Blue + Warning -> SGRLogInfo $ SetColor Foreground Dull Magenta + Error -> SGRLogInfo $ SetColor Foreground Dull Red + Critical -> SGRLogInfo $ SetColor Foreground Dull Red + Alert -> SGRLogInfo $ SetColor Foreground Dull Red + Emergency -> SGRLogInfo $ SetColor Foreground Dull Red + +setLogColor :: LogLevel -> IO () +setLogColor level = do + let sgrLogInfo = logLevelToColoredLogInfo level + case sgrLogInfo of + NotColored -> return () + SGRLogInfo sgr -> + setSGR [sgr] + +resetLogColor :: IO () +resetLogColor = setSGR [Reset] \ No newline at end of file diff --git a/src/Herp/Logger/StdoutANSITransport.hs b/src/Herp/Logger/StdoutANSITransport.hs new file mode 100644 index 0000000..dc7802c --- /dev/null +++ b/src/Herp/Logger/StdoutANSITransport.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} + +module Herp.Logger.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.Encoding qualified as T + +#if MIN_VERSION_aeson(2,0,0) +import "aeson" Data.Aeson.Key (fromText) +import "aeson" Data.Aeson.KeyMap as KM +import Herp.Logger.ANSI.Coloring (setLogColor, resetLogColor) +#else +import Data.HashMap.Strict qualified as KM +import Data.Text (Text) +fromText :: Text -> Text +fromText = id +#endif + +stdoutANSITransport :: LoggerSet -> LogLevel -> Transport +stdoutANSITransport 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 + -- TODO: Fix to allow colorized output + pushLogStrLn loggerSet $ toLogStr json + flush = flushLogStr loggerSet + in Transport + { name = name + , threshold = transportThreshold + , runTransport = runTransport + , flush + } From 643fdae44c4baf248a2566bd741adc99a787f180 Mon Sep 17 00:00:00 2001 From: ccycle Date: Wed, 10 Aug 2022 18:05:35 +0900 Subject: [PATCH 2/8] Fix functions for coloring --- herp-logger.cabal | 1 + src/Herp/Logger/ANSI/Coloring.hs | 48 ++++++++++++++------------ src/Herp/Logger/StdoutANSITransport.hs | 6 ++-- 3 files changed, 29 insertions(+), 26 deletions(-) diff --git a/herp-logger.cabal b/herp-logger.cabal index dd4132a..8d17d4b 100644 --- a/herp-logger.cabal +++ b/herp-logger.cabal @@ -75,6 +75,7 @@ library , async , base >=4.7 && <5 , bytestring + , colour , fast-logger , generic-data , monad-logger diff --git a/src/Herp/Logger/ANSI/Coloring.hs b/src/Herp/Logger/ANSI/Coloring.hs index ecb5570..938c842 100644 --- a/src/Herp/Logger/ANSI/Coloring.hs +++ b/src/Herp/Logger/ANSI/Coloring.hs @@ -1,33 +1,35 @@ -module Herp.Logger.ANSI.Coloring ( - module Herp.Logger.ANSI.Coloring, - module System.Console.ANSI -) - where +module Herp.Logger.ANSI.Coloring where +import Data.Colour.SRGB +import Data.String import Herp.Logger.LogLevel (LogLevel (..)) import System.Console.ANSI --- import System.Console.ANSIhttps://hackage.haskell.org/package/ansi-terminal-0.11.3/docs/System-Console-ANSI-Types.html#t:SGR -data SGRLogInfo = NotColored | SGRLogInfo SGR +-- https://hackage.haskell.org/package/ansi-terminal-0.11.3/docs/System-Console-ANSI-Types.html#t:SGR +data SGRLogInfo = NotColored | SGRLogInfo [SGR] logLevelToColoredLogInfo :: LogLevel -> SGRLogInfo logLevelToColoredLogInfo level = case level of - Debug -> SGRLogInfo $ SetColor Foreground Dull Blue - Informational -> NotColored - Notice -> SGRLogInfo $ SetColor Foreground Dull Blue - Warning -> SGRLogInfo $ SetColor Foreground Dull Magenta - Error -> SGRLogInfo $ SetColor Foreground Dull Red - Critical -> SGRLogInfo $ SetColor Foreground Dull Red - Alert -> SGRLogInfo $ SetColor Foreground Dull Red - Emergency -> SGRLogInfo $ SetColor Foreground Dull Red + Debug -> SGRLogInfo [SetRGBColor Background $ sRGB24 196 196 196] -- Grey + Informational -> SGRLogInfo [SetRGBColor Background $ sRGB24 155 204 228] -- Light blue + Notice -> SGRLogInfo [SetRGBColor Background $ sRGB24 154 169 186] -- Grey + Warning -> SGRLogInfo [SetRGBColor Background $ sRGB24 237 179 89] -- Orange + Error -> SGRLogInfo [SetRGBColor Background $ sRGB24 226 86 77] -- Red + Critical -> SGRLogInfo [SetRGBColor Background $ sRGB24 202 9 10] -- Wine red + Alert -> SGRLogInfo [SetRGBColor Background $ sRGB24 152 0 0] -- #980000 + Emergency -> SGRLogInfo [SetRGBColor Background $ sRGB24 101 0 0] --- #650000 -setLogColor :: LogLevel -> IO () -setLogColor level = do +setLogColorStr :: IsString a => LogLevel -> a +setLogColorStr level = let sgrLogInfo = logLevelToColoredLogInfo level - case sgrLogInfo of - NotColored -> return () - SGRLogInfo sgr -> - setSGR [sgr] + in case sgrLogInfo of + NotColored -> "" + SGRLogInfo sgr -> + fromString (setSGRCode sgr) -resetLogColor :: IO () -resetLogColor = setSGR [Reset] \ No newline at end of file +resetLogColorStr :: IsString a => a +resetLogColorStr = fromString (setSGRCode [Reset]) + +coloringLogInfoStr :: (IsString a, Semigroup a) => LogLevel -> a -> a +-- coloringLogInfoStr level str = setLogColorStr level <> str <> resetLogColorStr +coloringLogInfoStr level str = setLogColorStr level <> " " <> resetLogColorStr <> " " <> str diff --git a/src/Herp/Logger/StdoutANSITransport.hs b/src/Herp/Logger/StdoutANSITransport.hs index dc7802c..1ec2ea9 100644 --- a/src/Herp/Logger/StdoutANSITransport.hs +++ b/src/Herp/Logger/StdoutANSITransport.hs @@ -15,7 +15,7 @@ import Data.Text.Encoding qualified as T #if MIN_VERSION_aeson(2,0,0) import "aeson" Data.Aeson.Key (fromText) import "aeson" Data.Aeson.KeyMap as KM -import Herp.Logger.ANSI.Coloring (setLogColor, resetLogColor) +import Herp.Logger.ANSI.Coloring #else import Data.HashMap.Strict qualified as KM import Data.Text (Text) @@ -34,8 +34,8 @@ stdoutANSITransport loggerSet transportThreshold = ) let value = A.pairs $ series <> foldMap (uncurry (.=)) (KM.toList extra) let json = A.encodingToLazyByteString value - -- TODO: Fix to allow colorized output - pushLogStrLn loggerSet $ toLogStr json + -- pushLogStrLn loggerSet (toLogStr json) + pushLogStrLn loggerSet (toLogStr (coloringLogInfoStr level json)) flush = flushLogStr loggerSet in Transport { name = name From 0df7acd630cb4c7f7a87fd10ae7318bcb2f909b5 Mon Sep 17 00:00:00 2001 From: ccycle Date: Mon, 15 Aug 2022 10:24:55 +0900 Subject: [PATCH 3/8] Move functions in `StdoutANSITransport` --- src/Herp/Logger/StdoutANSITransport.hs | 45 --------------------- src/Herp/Logger/StdoutTransport.hs | 54 +++++++++++++++++++------- 2 files changed, 39 insertions(+), 60 deletions(-) delete mode 100644 src/Herp/Logger/StdoutANSITransport.hs diff --git a/src/Herp/Logger/StdoutANSITransport.hs b/src/Herp/Logger/StdoutANSITransport.hs deleted file mode 100644 index 1ec2ea9..0000000 --- a/src/Herp/Logger/StdoutANSITransport.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Herp.Logger.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.Encoding qualified as T - -#if MIN_VERSION_aeson(2,0,0) -import "aeson" Data.Aeson.Key (fromText) -import "aeson" Data.Aeson.KeyMap as KM -import Herp.Logger.ANSI.Coloring -#else -import Data.HashMap.Strict qualified as KM -import Data.Text (Text) -fromText :: Text -> Text -fromText = id -#endif - -stdoutANSITransport :: LoggerSet -> LogLevel -> Transport -stdoutANSITransport 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) - pushLogStrLn loggerSet (toLogStr (coloringLogInfoStr level json)) - flush = flushLogStr loggerSet - in Transport - { name = name - , threshold = transportThreshold - , runTransport = runTransport - , flush - } diff --git a/src/Herp/Logger/StdoutTransport.hs b/src/Herp/Logger/StdoutTransport.hs index c540615..1d54187 100644 --- a/src/Herp/Logger/StdoutTransport.hs +++ b/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,18 +27,9 @@ 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 @@ -40,3 +37,30 @@ stdoutTransport loggerSet 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 + ) + value = A.pairs $ series <> foldMap (uncurry (.=)) (KM.toList extra) + in value + +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) From 5e2bb7ca3817f79982e4cc4bc9cc37267d3332be Mon Sep 17 00:00:00 2001 From: ccycle Date: Mon, 15 Aug 2022 10:25:26 +0900 Subject: [PATCH 4/8] Remove `SGRLogInfo` --- src/Herp/Logger/ANSI/Coloring.hs | 29 ++++++++++++----------------- 1 file changed, 12 insertions(+), 17 deletions(-) diff --git a/src/Herp/Logger/ANSI/Coloring.hs b/src/Herp/Logger/ANSI/Coloring.hs index 938c842..11a7981 100644 --- a/src/Herp/Logger/ANSI/Coloring.hs +++ b/src/Herp/Logger/ANSI/Coloring.hs @@ -6,30 +6,25 @@ 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 -data SGRLogInfo = NotColored | SGRLogInfo [SGR] -logLevelToColoredLogInfo :: LogLevel -> SGRLogInfo -logLevelToColoredLogInfo level = case level of - Debug -> SGRLogInfo [SetRGBColor Background $ sRGB24 196 196 196] -- Grey - Informational -> SGRLogInfo [SetRGBColor Background $ sRGB24 155 204 228] -- Light blue - Notice -> SGRLogInfo [SetRGBColor Background $ sRGB24 154 169 186] -- Grey - Warning -> SGRLogInfo [SetRGBColor Background $ sRGB24 237 179 89] -- Orange - Error -> SGRLogInfo [SetRGBColor Background $ sRGB24 226 86 77] -- Red - Critical -> SGRLogInfo [SetRGBColor Background $ sRGB24 202 9 10] -- Wine red - Alert -> SGRLogInfo [SetRGBColor Background $ sRGB24 152 0 0] -- #980000 - Emergency -> SGRLogInfo [SetRGBColor Background $ sRGB24 101 0 0] --- #650000 +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 = logLevelToColoredLogInfo level - in case sgrLogInfo of - NotColored -> "" - SGRLogInfo sgr -> - fromString (setSGRCode sgr) + 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 <> str <> resetLogColorStr coloringLogInfoStr level str = setLogColorStr level <> " " <> resetLogColorStr <> " " <> str From 738f8b0887b3ab633d29f22d638f485650ebd111 Mon Sep 17 00:00:00 2001 From: ccycle Date: Mon, 15 Aug 2022 10:58:53 +0900 Subject: [PATCH 5/8] Remove deprecated module in `herp-logger.cabal` --- herp-logger.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/herp-logger.cabal b/herp-logger.cabal index 8d17d4b..9b4ed53 100644 --- a/herp-logger.cabal +++ b/herp-logger.cabal @@ -19,7 +19,6 @@ library Herp.Logger.StdoutTransport Herp.Logger.Transport Herp.Logger.ANSI.Coloring - Herp.Logger.StdoutANSITransport hs-source-dirs: src default-extensions: From 359691c31a790aa18011a1746f53b4708fece999 Mon Sep 17 00:00:00 2001 From: ccycle Date: Mon, 15 Aug 2022 11:35:41 +0900 Subject: [PATCH 6/8] Add tests for `stdoutANSITransport` --- tests/stdout.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/tests/stdout.hs b/tests/stdout.hs index 00abb86..4d65b9f 100644 --- a/tests/stdout.hs +++ b/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,12 @@ 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 + loggerLevelTest loggerSet [stdoutANSITransport loggerSet Debug] Informational From 601d8aa39599930341bb45540e750e121758406e Mon Sep 17 00:00:00 2001 From: ccycle Date: Mon, 15 Aug 2022 11:53:08 +0900 Subject: [PATCH 7/8] Remove binding `value` --- src/Herp/Logger/StdoutTransport.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Herp/Logger/StdoutTransport.hs b/src/Herp/Logger/StdoutTransport.hs index 1d54187..1fce769 100644 --- a/src/Herp/Logger/StdoutTransport.hs +++ b/src/Herp/Logger/StdoutTransport.hs @@ -46,8 +46,7 @@ convertTransportInputToEncoding <> "date" .= T.decodeUtf8 (SB.fromShort date) <> "message" .= message ) - value = A.pairs $ series <> foldMap (uncurry (.=)) (KM.toList extra) - in value + in A.pairs $ series <> foldMap (uncurry (.=)) (KM.toList extra) stdoutTransport :: LoggerSet -> LogLevel -> Transport stdoutTransport = stdoutTransport' "stdout" push From fd374aff4c21420f7deac28fb81d3e9cc8d5bd13 Mon Sep 17 00:00:00 2001 From: ccycle Date: Mon, 15 Aug 2022 11:53:54 +0900 Subject: [PATCH 8/8] Remove threshold test for `stdoutANSITransport` --- tests/stdout.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/stdout.hs b/tests/stdout.hs index 4d65b9f..5255816 100644 --- a/tests/stdout.hs +++ b/tests/stdout.hs @@ -31,4 +31,3 @@ main = bracket (LS.newStdoutLoggerSet 4096) LS.rmLoggerSet $ \loggerSet -> do loggerLevelTest loggerSet [stdoutTransport loggerSet Debug] Debug loggerLevelTest loggerSet [stdoutTransport loggerSet Debug] Informational loggerLevelTest loggerSet [stdoutANSITransport loggerSet Debug] Debug - loggerLevelTest loggerSet [stdoutANSITransport loggerSet Debug] Informational