{-# LANGUAGE TupleSections #-}
module Freckle.App.Logging
(
HasLogging(..)
, getLogDefaultANSI
, getLogBehaviors
, LogLevel
, LogFormat(..)
, LogLocation(..)
, parseEnvLogFormat
, parseEnvLogLevel
, parseEnvLogLocation
, runAppLoggerT
, formatJsonLogStr
, formatJsonNoLoc
, formatJson
, formatTerminal
) where
import Freckle.App.Prelude
import Control.Monad.Logger
import Data.Aeson (ToJSON, encode, object, (.=))
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 qualified Freckle.App.Env as Env
import System.Console.ANSI
( Color(Blue, Magenta, Red, Yellow)
, ColorIntensity(Dull)
, ConsoleLayer(Foreground)
, SGR(Reset, SetColor)
, hSupportsANSI
, setSGRCode
)
import System.IO (stderr, stdout)
data LogFormat
= FormatJSON
| FormatTerminal
data LogLocation
= LogStdout
| LogStderr
| LogFile FilePath
class HasLogging a where
getLogLevel :: a -> LogLevel
getLogFormat :: a -> LogFormat
getLogLocation :: a -> LogLocation
getLogDefaultANSI :: HasLogging a => a -> Bool
getLogDefaultANSI :: a -> Bool
getLogDefaultANSI a
app = case (a -> LogLocation
forall a. HasLogging a => a -> LogLocation
getLogLocation a
app, a -> LogFormat
forall a. HasLogging a => a -> LogFormat
getLogFormat a
app) of
(LogLocation
LogStdout, LogFormat
FormatTerminal) -> Bool
True
(LogLocation
LogStdout, LogFormat
FormatJSON) -> Bool
False
(LogLocation
LogStderr, LogFormat
FormatTerminal) -> Bool
True
(LogLocation
LogStderr, LogFormat
FormatJSON) -> Bool
False
(LogFile FilePath
_, LogFormat
FormatTerminal) -> Bool
False
(LogFile FilePath
_, LogFormat
FormatJSON) -> Bool
False
getLogBehaviors :: HasLogging a => a -> IO (ByteString -> IO (), Bool)
getLogBehaviors :: a -> IO (ByteString -> IO (), Bool)
getLogBehaviors a
app = case a -> LogLocation
forall a. HasLogging a => a -> LogLocation
getLogLocation a
app of
LogLocation
LogStdout -> (Handle -> ByteString -> IO ()
BS8.hPutStr Handle
stdout, ) (Bool -> (ByteString -> IO (), Bool))
-> IO Bool -> IO (ByteString -> IO (), Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hSupportsANSI Handle
stdout
LogLocation
LogStderr -> (Handle -> ByteString -> IO ()
BS8.hPutStr Handle
stderr, ) (Bool -> (ByteString -> IO (), Bool))
-> IO Bool -> IO (ByteString -> IO (), Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hSupportsANSI Handle
stderr
LogFile FilePath
path -> (ByteString -> IO (), Bool) -> IO (ByteString -> IO (), Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> ByteString -> IO ()
BS8.appendFile FilePath
path, Bool
False)
parseEnvLogLevel :: Env.Parser LogLevel
parseEnvLogLevel :: Parser LogLevel
parseEnvLogLevel = Reader LogLevel -> FilePath -> Mod LogLevel -> Parser LogLevel
forall a. Reader a -> FilePath -> Mod a -> Parser a
Env.var Reader LogLevel
parse FilePath
"LOG_LEVEL" (Mod LogLevel -> Parser LogLevel)
-> Mod LogLevel -> Parser LogLevel
forall a b. (a -> b) -> a -> b
$ LogLevel -> Mod LogLevel
forall a. a -> Mod a
Env.def LogLevel
LevelWarn
where
parse :: Reader LogLevel
parse = (FilePath -> Either FilePath LogLevel) -> Reader LogLevel
forall a. (FilePath -> Either FilePath a) -> Reader a
Env.eitherReader ((FilePath -> Either FilePath LogLevel) -> Reader LogLevel)
-> (FilePath -> Either FilePath LogLevel) -> Reader LogLevel
forall a b. (a -> b) -> a -> b
$ \case
FilePath
"warn" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LevelWarn
FilePath
"error" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LevelError
FilePath
"debug" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LevelDebug
FilePath
"info" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LevelInfo
FilePath
level -> FilePath -> Either FilePath LogLevel
forall a b. a -> Either a b
Left (FilePath -> Either FilePath LogLevel)
-> FilePath -> Either FilePath LogLevel
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected log level: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
level
parseEnvLogFormat :: Env.Parser LogFormat
parseEnvLogFormat :: Parser LogFormat
parseEnvLogFormat = Reader LogFormat -> FilePath -> Mod LogFormat -> Parser LogFormat
forall a. Reader a -> FilePath -> Mod a -> Parser a
Env.var Reader LogFormat
parse FilePath
"LOG_FORMAT" (Mod LogFormat -> Parser LogFormat)
-> Mod LogFormat -> Parser LogFormat
forall a b. (a -> b) -> a -> b
$ LogFormat -> Mod LogFormat
forall a. a -> Mod a
Env.def LogFormat
FormatTerminal
where
parse :: Reader LogFormat
parse = (FilePath -> Either FilePath LogFormat) -> Reader LogFormat
forall a. (FilePath -> Either FilePath a) -> Reader a
Env.eitherReader ((FilePath -> Either FilePath LogFormat) -> Reader LogFormat)
-> (FilePath -> Either FilePath LogFormat) -> Reader LogFormat
forall a b. (a -> b) -> a -> b
$ \case
FilePath
"json" -> LogFormat -> Either FilePath LogFormat
forall a b. b -> Either a b
Right LogFormat
FormatJSON
FilePath
"terminal" -> LogFormat -> Either FilePath LogFormat
forall a b. b -> Either a b
Right LogFormat
FormatTerminal
FilePath
format -> FilePath -> Either FilePath LogFormat
forall a b. a -> Either a b
Left (FilePath -> Either FilePath LogFormat)
-> FilePath -> Either FilePath LogFormat
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected format: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
format
parseEnvLogLocation :: Env.Parser LogLocation
parseEnvLogLocation :: Parser LogLocation
parseEnvLogLocation = Reader LogLocation
-> FilePath -> Mod LogLocation -> Parser LogLocation
forall a. Reader a -> FilePath -> Mod a -> Parser a
Env.var Reader LogLocation
parse FilePath
"LOG_LOCATION" (Mod LogLocation -> Parser LogLocation)
-> Mod LogLocation -> Parser LogLocation
forall a b. (a -> b) -> a -> b
$ LogLocation -> Mod LogLocation
forall a. a -> Mod a
Env.def LogLocation
LogStdout
where
parse :: Reader LogLocation
parse = (FilePath -> Either FilePath LogLocation) -> Reader LogLocation
forall a. (FilePath -> Either FilePath a) -> Reader a
Env.eitherReader ((FilePath -> Either FilePath LogLocation) -> Reader LogLocation)
-> (FilePath -> Either FilePath LogLocation) -> Reader LogLocation
forall a b. (a -> b) -> a -> b
$ \case
FilePath
"stdout" -> LogLocation -> Either FilePath LogLocation
forall a b. b -> Either a b
Right LogLocation
LogStdout
FilePath
"stderr" -> LogLocation -> Either FilePath LogLocation
forall a b. b -> Either a b
Right LogLocation
LogStderr
FilePath
"file" -> LogLocation -> Either FilePath LogLocation
forall a b. b -> Either a b
Right (LogLocation -> Either FilePath LogLocation)
-> LogLocation -> Either FilePath LogLocation
forall a b. (a -> b) -> a -> b
$ FilePath -> LogLocation
LogFile FilePath
"fancy.log"
FilePath
file -> LogLocation -> Either FilePath LogLocation
forall a b. b -> Either a b
Right (LogLocation -> Either FilePath LogLocation)
-> LogLocation -> Either FilePath LogLocation
forall a b. (a -> b) -> a -> b
$ FilePath -> LogLocation
LogFile FilePath
file
runAppLoggerT :: HasLogging a => a -> LoggingT IO b -> IO b
runAppLoggerT :: a -> LoggingT IO b -> IO b
runAppLoggerT a
app LoggingT IO b
f = do
(ByteString -> IO ()
putLogLine, Bool
isANSI) <- a -> IO (ByteString -> IO (), Bool)
forall a. HasLogging a => a -> IO (ByteString -> IO (), Bool)
getLogBehaviors a
app
let
logger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger = case a -> LogFormat
forall a. HasLogging a => a -> LogFormat
getLogFormat a
app of
LogFormat
FormatJSON -> (ByteString -> IO ())
-> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall t.
(ByteString -> t) -> Loc -> LogSource -> LogLevel -> LogStr -> t
jsonLogger ByteString -> IO ()
putLogLine
LogFormat
FormatTerminal -> (ByteString -> IO ())
-> Bool -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall a t.
ToLogStr a =>
(ByteString -> t) -> Bool -> Loc -> LogSource -> LogLevel -> a -> t
ansiLogger ByteString -> IO ()
putLogLine Bool
isANSI
(LoggingT IO b
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO b)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT IO b
-> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO b
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO b
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger
(LoggingT IO b -> IO b) -> LoggingT IO b -> IO b
forall a b. (a -> b) -> a -> b
$ (LogSource -> LogLevel -> Bool) -> LoggingT IO b -> LoggingT IO b
forall (m :: * -> *) a.
(LogSource -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
filterLogger (\LogSource
_ LogLevel
level -> LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= a -> LogLevel
forall a. HasLogging a => a -> LogLevel
getLogLevel a
app) LoggingT IO b
f
where
jsonLogger :: (ByteString -> t) -> Loc -> LogSource -> LogLevel -> LogStr -> t
jsonLogger ByteString -> t
putLogLine Loc
loc LogSource
src LogLevel
level LogStr
str =
ByteString -> t
putLogLine (ByteString -> t) -> ByteString -> t
forall a b. (a -> b) -> a -> b
$ Loc -> LogSource -> LogLevel -> LogStr -> ByteString
formatJsonLogStr Loc
loc LogSource
src LogLevel
level LogStr
str
ansiLogger :: (ByteString -> t) -> Bool -> Loc -> LogSource -> LogLevel -> a -> t
ansiLogger ByteString -> t
putLogLine Bool
isANSI Loc
loc LogSource
src LogLevel
level a
str =
ByteString -> t
putLogLine (ByteString -> t) -> ByteString -> t
forall a b. (a -> b) -> a -> b
$ Bool -> Loc -> LogSource -> LogLevel -> a -> ByteString
forall a.
ToLogStr a =>
Bool -> Loc -> LogSource -> LogLevel -> a -> ByteString
formatTerminal Bool
isANSI Loc
loc LogSource
src LogLevel
level a
str
formatJsonLogStr :: Loc -> LogSource -> LogLevel -> LogStr -> ByteString
formatJsonLogStr :: Loc -> LogSource -> LogLevel -> LogStr -> ByteString
formatJsonLogStr Loc
loc LogSource
src LogLevel
level =
Maybe Loc -> Maybe LogSource -> LogLevel -> LogSource -> ByteString
forall a.
ToJSON a =>
Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
formatJson (Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc) (LogSource -> Maybe LogSource
forall a. a -> Maybe a
Just LogSource
src) LogLevel
level (LogSource -> ByteString)
-> (LogStr -> LogSource) -> LogStr -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LogSource
decodeUtf8 (ByteString -> LogSource)
-> (LogStr -> ByteString) -> LogStr -> LogSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
fromLogStr
formatJsonNoLoc :: ToJSON a => LogLevel -> a -> ByteString
formatJsonNoLoc :: LogLevel -> a -> ByteString
formatJsonNoLoc = Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
forall a.
ToJSON a =>
Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
formatJson Maybe Loc
forall a. Maybe a
Nothing Maybe LogSource
forall a. Maybe a
Nothing
formatJson
:: ToJSON a => Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
formatJson :: Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
formatJson Maybe Loc
loc Maybe LogSource
src LogLevel
level a
msg = (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n") (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
[ LogSource
"loc" LogSource -> Maybe Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= (Loc -> Value
locJson (Loc -> Value) -> Maybe Loc -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Loc
loc)
, LogSource
"src" LogSource -> Maybe LogSource -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= Maybe LogSource
src
, LogSource
"level" LogSource -> LogSource -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= LogLevel -> LogSource
levelText LogLevel
level
, LogSource
"message" LogSource -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= a
msg
]
where
locJson :: Loc -> Value
locJson Loc {FilePath
CharPos
loc_end :: Loc -> CharPos
loc_start :: Loc -> CharPos
loc_module :: Loc -> FilePath
loc_package :: Loc -> FilePath
loc_filename :: Loc -> FilePath
loc_end :: CharPos
loc_start :: CharPos
loc_module :: FilePath
loc_package :: FilePath
loc_filename :: FilePath
..} = [Pair] -> Value
object
[ LogSource
"filename" LogSource -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= FilePath
loc_filename
, LogSource
"package" LogSource -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= FilePath
loc_package
, LogSource
"module" LogSource -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= FilePath
loc_module
, LogSource
"start" LogSource -> CharPos -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= CharPos
loc_start
, LogSource
"end" LogSource -> CharPos -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= CharPos
loc_end
]
formatTerminal
:: ToLogStr a
=> Bool
-> Loc
-> LogSource
-> LogLevel
-> a
-> ByteString
formatTerminal :: Bool -> Loc -> LogSource -> LogLevel -> a -> ByteString
formatTerminal Bool
isANSI Loc
loc LogSource
src LogLevel
level a
str = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
[ SGR -> ByteString
esc (SGR -> ByteString) -> SGR -> ByteString
forall a b. (a -> b) -> a -> b
$ LogLevel -> SGR
style LogLevel
level
, ByteString -> Word8 -> ByteString
BS.snoc ByteString
levelStr Word8
forall b. Num b => b
labelEnd
, SGR -> ByteString
esc SGR
Reset
, ByteString -> [ByteString] -> ByteString
BS.intercalate (Word8 -> ByteString
BS.singleton Word8
forall b. Num b => b
labelEnd) [ByteString]
logStr
, SGR -> ByteString
esc SGR
Reset
]
where
labelEnd :: b
labelEnd = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
']'
(ByteString
levelStr : [ByteString]
logStr) =
Word8 -> ByteString -> [ByteString]
BS.split Word8
forall b. Num b => b
labelEnd (ByteString -> [ByteString])
-> (LogStr -> ByteString) -> LogStr -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
fromLogStr (LogStr -> [ByteString]) -> LogStr -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Loc -> LogSource -> LogLevel -> LogStr -> LogStr
defaultLogStr Loc
loc LogSource
src LogLevel
level (LogStr -> LogStr) -> LogStr -> LogStr
forall a b. (a -> b) -> a -> b
$ a -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr a
str
esc :: SGR -> ByteString
esc SGR
x = if Bool
isANSI then FilePath -> ByteString
BS8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ [SGR] -> FilePath
setSGRCode [SGR
x] else ByteString
""
style :: LogLevel -> SGR
style :: LogLevel -> SGR
style = \case
LogLevel
LevelDebug -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Magenta
LogLevel
LevelInfo -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Blue
LogLevel
LevelWarn -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Yellow
LogLevel
LevelError -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Red
LevelOther LogSource
_ -> SGR
Reset
levelText :: LogLevel -> Text
levelText :: LogLevel -> LogSource
levelText = \case
LogLevel
LevelDebug -> LogSource
"Debug"
LogLevel
LevelInfo -> LogSource
"Info"
LogLevel
LevelWarn -> LogSource
"Warn"
LogLevel
LevelError -> LogSource
"Error"
LevelOther LogSource
x -> LogSource
x