{-# LANGUAGE LambdaCase #-}
module Z.IO.Logger
(
Logger(..)
, LoggerConfig(..)
, defaultLoggerConfig
, setDefaultLogger
, getDefaultLogger
, flushDefaultLogger
, withDefaultLogger
, newLogger
, newColoredLogger
, debug
, info
, warning
, fatal
, critical
, otherLevel
, debugTo
, infoTo
, warningTo
, fatalTo
, otherLevelTo
, defaultTSCache
, defaultFmtCallStack
, defaultLevelFmt
, LogFormatter, defaultFmt, coloredFmt
, pushLogIORef, flushLogIORef
, Level
, pattern DEBUG
, pattern INFO
, pattern WARNING
, pattern FATAL
, pattern CRITICAL
, pattern NOTSET
) where
import Control.Concurrent.MVar
import Control.Monad
import Data.IORef
import GHC.Stack
import System.IO.Unsafe (unsafePerformIO)
import qualified Z.Data.Builder as B
import qualified Z.Data.CBytes as CB
import Z.Data.Vector.Base as V
import Z.IO.Buffered
import Z.IO.Exception
import Z.IO.LowResTimer
import Z.IO.StdStream
import Z.IO.StdStream.Ansi (AnsiColor (..), color)
import Z.IO.Time
type LogFormatter = B.Builder ()
-> Level
-> B.Builder ()
-> CallStack
-> B.Builder ()
data Logger = Logger
{ Logger -> Builder () -> IO ()
loggerPushBuilder :: B.Builder () -> IO ()
, Logger -> IO ()
flushLogger :: IO ()
, Logger -> IO ()
flushLoggerThrottled :: IO ()
, Logger -> IO (Builder ())
loggerTSCache :: IO (B.Builder ())
, Logger -> LogFormatter
loggerFmt :: LogFormatter
, Logger -> Level
loggerLevel :: {-# UNPACK #-} !Level
}
data LoggerConfig = LoggerConfig
{ LoggerConfig -> Level
loggerMinFlushInterval :: {-# UNPACK #-} !Int
, LoggerConfig -> Level
loggerLineBufSize :: {-# UNPACK #-} !Int
, LoggerConfig -> Level
loggerConfigLevel :: {-# UNPACK #-} !Level
}
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig = Level -> Level -> Level -> LoggerConfig
LoggerConfig Level
1 Level
240 Level
NOTSET
defaultTSCache :: IO (B.Builder ())
{-# NOINLINE defaultTSCache #-}
defaultTSCache :: IO (Builder ())
defaultTSCache = IO (IO (Builder ())) -> IO (Builder ())
forall a. IO a -> a
unsafePerformIO (IO (IO (Builder ())) -> IO (Builder ()))
-> IO (IO (Builder ())) -> IO (Builder ())
forall a b. (a -> b) -> a -> b
$ do
Level -> IO (Builder ()) -> IO (IO (Builder ()))
forall a. Level -> IO a -> IO (IO a)
throttle Level
1 (IO (Builder ()) -> IO (IO (Builder ())))
-> IO (Builder ()) -> IO (IO (Builder ()))
forall a b. (a -> b) -> a -> b
$ do
SystemTime
t <- IO SystemTime
getSystemTime
CBytes -> Builder ()
CB.toBuilder (CBytes -> Builder ()) -> IO CBytes -> IO (Builder ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CBytes -> SystemTime -> IO CBytes
formatSystemTime CBytes
iso8061DateFormat SystemTime
t
newLogger :: LoggerConfig
-> MVar BufferedOutput
-> IO Logger
newLogger :: LoggerConfig -> MVar BufferedOutput -> IO Logger
newLogger LoggerConfig{Level
loggerConfigLevel :: Level
loggerLineBufSize :: Level
loggerMinFlushInterval :: Level
loggerConfigLevel :: LoggerConfig -> Level
loggerLineBufSize :: LoggerConfig -> Level
loggerMinFlushInterval :: LoggerConfig -> Level
..} MVar BufferedOutput
oLock = do
IORef [Bytes]
logsRef <- [Bytes] -> IO (IORef [Bytes])
forall a. a -> IO (IORef a)
newIORef []
let flush :: IO ()
flush = HasCallStack => MVar BufferedOutput -> IORef [Bytes] -> IO ()
MVar BufferedOutput -> IORef [Bytes] -> IO ()
flushLogIORef MVar BufferedOutput
oLock IORef [Bytes]
logsRef
IO ()
throttledFlush <- Level -> IO () -> IO (IO ())
throttleTrailing_ Level
loggerMinFlushInterval IO ()
flush
Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$ (Builder () -> IO ())
-> IO ()
-> IO ()
-> IO (Builder ())
-> LogFormatter
-> Level
-> Logger
Logger (IORef [Bytes] -> Level -> Builder () -> IO ()
pushLogIORef IORef [Bytes]
logsRef Level
loggerLineBufSize)
IO ()
flush IO ()
throttledFlush IO (Builder ())
defaultTSCache LogFormatter
defaultFmt
Level
loggerConfigLevel
newColoredLogger :: LoggerConfig -> IO Logger
newColoredLogger :: LoggerConfig -> IO Logger
newColoredLogger LoggerConfig{Level
loggerConfigLevel :: Level
loggerLineBufSize :: Level
loggerMinFlushInterval :: Level
loggerConfigLevel :: LoggerConfig -> Level
loggerLineBufSize :: LoggerConfig -> Level
loggerMinFlushInterval :: LoggerConfig -> Level
..} = do
IORef [Bytes]
logsRef <- [Bytes] -> IO (IORef [Bytes])
forall a. a -> IO (IORef a)
newIORef []
let flush :: IO ()
flush = HasCallStack => MVar BufferedOutput -> IORef [Bytes] -> IO ()
MVar BufferedOutput -> IORef [Bytes] -> IO ()
flushLogIORef MVar BufferedOutput
stderrBuf IORef [Bytes]
logsRef
IO ()
throttledFlush <- Level -> IO () -> IO (IO ())
throttleTrailing_ Level
loggerMinFlushInterval IO ()
flush
Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$ (Builder () -> IO ())
-> IO ()
-> IO ()
-> IO (Builder ())
-> LogFormatter
-> Level
-> Logger
Logger (IORef [Bytes] -> Level -> Builder () -> IO ()
pushLogIORef IORef [Bytes]
logsRef Level
loggerLineBufSize)
IO ()
flush IO ()
throttledFlush IO (Builder ())
defaultTSCache
(if StdStream -> Bool
isStdStreamTTY StdStream
stderr then LogFormatter
coloredFmt
else LogFormatter
defaultFmt)
Level
loggerConfigLevel
pushLogIORef :: IORef [V.Bytes]
-> Int
-> B.Builder ()
-> IO ()
pushLogIORef :: IORef [Bytes] -> Level -> Builder () -> IO ()
pushLogIORef IORef [Bytes]
logsRef Level
loggerLineBufSize Builder ()
b = do
let !bs :: Bytes
bs = Level -> Builder () -> Bytes
forall a. Level -> Builder a -> Bytes
B.buildWith Level
loggerLineBufSize Builder ()
b
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bytes -> Bool
forall (v :: * -> *) a. Vec v a => v a -> Bool
V.null Bytes
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef [Bytes] -> ([Bytes] -> ([Bytes], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Bytes]
logsRef (\ [Bytes]
bss -> (Bytes
bsBytes -> [Bytes] -> [Bytes]
forall a. a -> [a] -> [a]
:[Bytes]
bss, ()))
flushLogIORef :: HasCallStack => MVar BufferedOutput -> IORef [V.Bytes] -> IO ()
flushLogIORef :: MVar BufferedOutput -> IORef [Bytes] -> IO ()
flushLogIORef MVar BufferedOutput
oLock IORef [Bytes]
logsRef =
MVar BufferedOutput -> (BufferedOutput -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar BufferedOutput
oLock ((BufferedOutput -> IO ()) -> IO ())
-> (BufferedOutput -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BufferedOutput
o -> do
[Bytes]
bss <- IORef [Bytes] -> ([Bytes] -> ([Bytes], [Bytes])) -> IO [Bytes]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Bytes]
logsRef (\ [Bytes]
bss -> ([], [Bytes]
bss))
[Bytes] -> (Bytes -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Bytes] -> [Bytes]
forall a. [a] -> [a]
reverse [Bytes]
bss) (HasCallStack => BufferedOutput -> Bytes -> IO ()
BufferedOutput -> Bytes -> IO ()
writeBuffer BufferedOutput
o)
HasCallStack => BufferedOutput -> IO ()
BufferedOutput -> IO ()
flushBuffer BufferedOutput
o
defaultFmt :: LogFormatter
defaultFmt :: LogFormatter
defaultFmt Builder ()
ts Level
level Builder ()
content CallStack
cstack = do
Builder () -> Builder ()
B.square (Level -> Builder ()
defaultLevelFmt Level
level)
Builder () -> Builder ()
B.square Builder ()
ts
Builder () -> Builder ()
B.square (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ CallStack -> Builder ()
defaultFmtCallStack CallStack
cstack
Builder ()
content
Char -> Builder ()
B.char8 Char
'\n'
coloredFmt :: LogFormatter
coloredFmt :: LogFormatter
coloredFmt Builder ()
ts Level
level Builder ()
content CallStack
cstack = do
let blevel :: Builder ()
blevel = Level -> Builder ()
defaultLevelFmt Level
level
Builder () -> Builder ()
B.square (case Level
level of
Level
DEBUG -> AnsiColor -> Builder () -> Builder ()
color AnsiColor
Cyan Builder ()
blevel
Level
WARNING -> AnsiColor -> Builder () -> Builder ()
color AnsiColor
Yellow Builder ()
blevel
Level
FATAL -> AnsiColor -> Builder () -> Builder ()
color AnsiColor
Red Builder ()
blevel
Level
CRITICAL -> AnsiColor -> Builder () -> Builder ()
color AnsiColor
Red Builder ()
blevel
Level
_ -> Builder ()
blevel)
Builder () -> Builder ()
B.square Builder ()
ts
Builder () -> Builder ()
B.square (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ CallStack -> Builder ()
defaultFmtCallStack CallStack
cstack
Builder ()
content
Char -> Builder ()
B.char8 Char
'\n'
defaultFmtCallStack :: CallStack -> B.Builder ()
defaultFmtCallStack :: CallStack -> Builder ()
defaultFmtCallStack CallStack
cs =
case [([Char], SrcLoc)] -> [([Char], SrcLoc)]
forall a. [a] -> [a]
reverse ([([Char], SrcLoc)] -> [([Char], SrcLoc)])
-> [([Char], SrcLoc)] -> [([Char], SrcLoc)]
forall a b. (a -> b) -> a -> b
$ CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
cs of
[] -> Builder ()
"<no call stack found>"
([Char]
_, SrcLoc
loc):[([Char], SrcLoc)]
_ -> do
[Char] -> Builder ()
B.string8 (SrcLoc -> [Char]
srcLocFile SrcLoc
loc)
Char -> Builder ()
B.char8 Char
':'
Level -> Builder ()
forall a. (Integral a, Bounded a) => a -> Builder ()
B.int (SrcLoc -> Level
srcLocStartLine SrcLoc
loc)
Char -> Builder ()
B.char8 Char
':'
Level -> Builder ()
forall a. (Integral a, Bounded a) => a -> Builder ()
B.int (SrcLoc -> Level
srcLocStartCol SrcLoc
loc)
globalLogger :: IORef Logger
{-# NOINLINE globalLogger #-}
globalLogger :: IORef Logger
globalLogger = IO (IORef Logger) -> IORef Logger
forall a. IO a -> a
unsafePerformIO (IO (IORef Logger) -> IORef Logger)
-> IO (IORef Logger) -> IORef Logger
forall a b. (a -> b) -> a -> b
$
Logger -> IO (IORef Logger)
forall a. a -> IO (IORef a)
newIORef (Logger -> IO (IORef Logger)) -> IO Logger -> IO (IORef Logger)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LoggerConfig -> IO Logger
newColoredLogger LoggerConfig
defaultLoggerConfig
setDefaultLogger :: Logger -> IO ()
setDefaultLogger :: Logger -> IO ()
setDefaultLogger !Logger
logger = IORef Logger -> Logger -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Logger
globalLogger Logger
logger
getDefaultLogger :: IO Logger
getDefaultLogger :: IO Logger
getDefaultLogger = IORef Logger -> IO Logger
forall a. IORef a -> IO a
readIORef IORef Logger
globalLogger
flushDefaultLogger :: IO ()
flushDefaultLogger :: IO ()
flushDefaultLogger = IO Logger
getDefaultLogger IO Logger -> (Logger -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Logger -> IO ()
flushLogger
withDefaultLogger :: IO () -> IO ()
withDefaultLogger :: IO () -> IO ()
withDefaultLogger = (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
flushDefaultLogger)
type Level = Int
pattern CRITICAL :: Level
pattern $bCRITICAL :: Level
$mCRITICAL :: forall r. Level -> (Void# -> r) -> (Void# -> r) -> r
CRITICAL = 50
pattern FATAL :: Level
pattern $bFATAL :: Level
$mFATAL :: forall r. Level -> (Void# -> r) -> (Void# -> r) -> r
FATAL = 40
pattern WARNING :: Level
pattern $bWARNING :: Level
$mWARNING :: forall r. Level -> (Void# -> r) -> (Void# -> r) -> r
WARNING = 30
pattern INFO :: Level
pattern $bINFO :: Level
$mINFO :: forall r. Level -> (Void# -> r) -> (Void# -> r) -> r
INFO = 20
pattern DEBUG :: Level
pattern $bDEBUG :: Level
$mDEBUG :: forall r. Level -> (Void# -> r) -> (Void# -> r) -> r
DEBUG = 10
pattern NOTSET :: Level
pattern $bNOTSET :: Level
$mNOTSET :: forall r. Level -> (Void# -> r) -> (Void# -> r) -> r
NOTSET = 0
defaultLevelFmt :: Level -> B.Builder ()
defaultLevelFmt :: Level -> Builder ()
defaultLevelFmt Level
level = case Level
level of
Level
CRITICAL -> Builder ()
"CRITICAL"
Level
FATAL -> Builder ()
"FATAL"
Level
WARNING -> Builder ()
"WARNING"
Level
INFO -> Builder ()
"INFO"
Level
DEBUG -> Builder ()
"DEBUG"
Level
NOTSET -> Builder ()
"NOTSET"
Level
level' -> Builder ()
"LEVEL" Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Level -> Builder ()
forall a. (Integral a, Bounded a) => a -> Builder ()
B.int Level
level'
debug :: HasCallStack => B.Builder () -> IO ()
debug :: Builder () -> IO ()
debug = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
DEBUG Bool
False CallStack
HasCallStack => CallStack
callStack
info :: HasCallStack => B.Builder () -> IO ()
info :: Builder () -> IO ()
info = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
INFO Bool
False CallStack
HasCallStack => CallStack
callStack
warning :: HasCallStack => B.Builder () -> IO ()
warning :: Builder () -> IO ()
warning = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
WARNING Bool
False CallStack
HasCallStack => CallStack
callStack
fatal :: HasCallStack => B.Builder () -> IO ()
fatal :: Builder () -> IO ()
fatal = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
FATAL Bool
True CallStack
HasCallStack => CallStack
callStack
critical :: HasCallStack => B.Builder () -> IO ()
critical :: Builder () -> IO ()
critical = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
CRITICAL Bool
True CallStack
HasCallStack => CallStack
callStack
otherLevel :: HasCallStack
=> Level
-> Bool
-> B.Builder ()
-> IO ()
otherLevel :: Level -> Bool -> Builder () -> IO ()
otherLevel Level
level Bool
flushNow Builder ()
bu = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
level Bool
flushNow CallStack
HasCallStack => CallStack
callStack Builder ()
bu
otherLevel_ :: Level -> Bool -> CallStack -> B.Builder () -> IO ()
otherLevel_ :: Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
level Bool
flushNow CallStack
cstack Builder ()
bu = do
Logger
logger <- IO Logger
getDefaultLogger
Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
level Bool
flushNow CallStack
cstack Logger
logger Builder ()
bu
debugTo :: HasCallStack => Logger -> B.Builder () -> IO ()
debugTo :: Logger -> Builder () -> IO ()
debugTo = Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
DEBUG Bool
False CallStack
HasCallStack => CallStack
callStack
infoTo :: HasCallStack => Logger -> B.Builder () -> IO ()
infoTo :: Logger -> Builder () -> IO ()
infoTo = Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
INFO Bool
False CallStack
HasCallStack => CallStack
callStack
warningTo :: HasCallStack => Logger -> B.Builder () -> IO ()
warningTo :: Logger -> Builder () -> IO ()
warningTo = Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
WARNING Bool
False CallStack
HasCallStack => CallStack
callStack
fatalTo :: HasCallStack => Logger -> B.Builder () -> IO ()
fatalTo :: Logger -> Builder () -> IO ()
fatalTo = Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
FATAL Bool
True CallStack
HasCallStack => CallStack
callStack
otherLevelTo :: HasCallStack
=> Logger
-> Level
-> Bool
-> B.Builder ()
-> IO ()
otherLevelTo :: Logger -> Level -> Bool -> Builder () -> IO ()
otherLevelTo Logger
logger Level
level Bool
flushNow =
Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
level Bool
flushNow CallStack
HasCallStack => CallStack
callStack Logger
logger
otherLevelTo_ :: Level -> Bool -> CallStack -> Logger -> B.Builder () -> IO ()
otherLevelTo_ :: Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
level Bool
flushNow CallStack
cstack Logger
logger Builder ()
bu = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Level
level Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Logger -> Level
loggerLevel Logger
logger) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Builder ()
ts <- Logger -> IO (Builder ())
loggerTSCache Logger
logger
(Logger -> Builder () -> IO ()
loggerPushBuilder Logger
logger) (Builder () -> IO ()) -> Builder () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Logger -> LogFormatter
loggerFmt Logger
logger) Builder ()
ts Level
level Builder ()
bu CallStack
cstack
if Bool
flushNow
then Logger -> IO ()
flushLogger Logger
logger
else Logger -> IO ()
flushLoggerThrottled Logger
logger