{-# 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
{ loggerPushBuilder :: B.Builder () -> IO ()
, flushLogger :: IO ()
, flushLoggerThrottled :: IO ()
, loggerTSCache :: IO (B.Builder ())
, loggerFmt :: LogFormatter
, loggerLevel :: {-# UNPACK #-} !Level
}
data LoggerConfig = LoggerConfig
{ loggerMinFlushInterval :: {-# UNPACK #-} !Int
, loggerLineBufSize :: {-# UNPACK #-} !Int
, loggerConfigLevel :: {-# UNPACK #-} !Level
}
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig = LoggerConfig 1 240 NOTSET
defaultTSCache :: IO (B.Builder ())
{-# NOINLINE defaultTSCache #-}
defaultTSCache = unsafePerformIO $ do
throttle 1 $ do
t <- getSystemTime
CB.toBuilder <$> formatSystemTime iso8061DateFormat t
newLogger :: Output o
=> LoggerConfig
-> MVar (BufferedOutput o)
-> IO Logger
newLogger LoggerConfig{..} oLock = do
logsRef <- newIORef []
let flush = flushLogIORef oLock logsRef
throttledFlush <- throttleTrailing_ loggerMinFlushInterval flush
return $ Logger (pushLogIORef logsRef loggerLineBufSize)
flush throttledFlush defaultTSCache defaultFmt
loggerConfigLevel
newColoredLogger :: LoggerConfig -> IO Logger
newColoredLogger LoggerConfig{..} = do
logsRef <- newIORef []
let flush = flushLogIORef stderrBuf logsRef
throttledFlush <- throttleTrailing_ loggerMinFlushInterval flush
return $ Logger (pushLogIORef logsRef loggerLineBufSize)
flush throttledFlush defaultTSCache
(if isStdStreamTTY stderr then coloredFmt
else defaultFmt)
loggerConfigLevel
pushLogIORef :: IORef [V.Bytes]
-> Int
-> B.Builder ()
-> IO ()
pushLogIORef logsRef loggerLineBufSize b = do
let !bs = B.buildBytesWith loggerLineBufSize b
unless (V.null bs) $ atomicModifyIORef' logsRef (\ bss -> (bs:bss, ()))
flushLogIORef :: (HasCallStack, Output o) => MVar (BufferedOutput o) -> IORef [V.Bytes] -> IO ()
flushLogIORef oLock logsRef =
withMVar oLock $ \ o -> do
bss <- atomicModifyIORef' logsRef (\ bss -> ([], bss))
forM_ (reverse bss) (writeBuffer o)
flushBuffer o
defaultFmt :: LogFormatter
defaultFmt ts level content cstack = do
B.square (defaultLevelFmt level)
B.square ts
B.square $ defaultFmtCallStack cstack
content
B.char8 '\n'
coloredFmt :: LogFormatter
coloredFmt ts level content cstack = do
let blevel = defaultLevelFmt level
B.square (case level of
DEBUG -> color Cyan blevel
WARNING -> color Yellow blevel
FATAL -> color Red blevel
CRITICAL -> color Red blevel
_ -> blevel)
B.square ts
B.square $ defaultFmtCallStack cstack
content
B.char8 '\n'
defaultFmtCallStack :: CallStack -> B.Builder ()
defaultFmtCallStack cs =
case reverse $ getCallStack cs of
[] -> "<no call stack found>"
(_, loc):_ -> do
B.string8 (srcLocFile loc)
B.char8 ':'
B.int (srcLocStartLine loc)
B.char8 ':'
B.int (srcLocStartCol loc)
globalLogger :: IORef Logger
{-# NOINLINE globalLogger #-}
globalLogger = unsafePerformIO $
newIORef =<< newColoredLogger defaultLoggerConfig
setDefaultLogger :: Logger -> IO ()
setDefaultLogger !logger = atomicWriteIORef globalLogger logger
getDefaultLogger :: IO Logger
getDefaultLogger = readIORef globalLogger
flushDefaultLogger :: IO ()
flushDefaultLogger = getDefaultLogger >>= flushLogger
withDefaultLogger :: IO () -> IO ()
withDefaultLogger = (`finally` flushDefaultLogger)
type Level = Int
pattern CRITICAL :: Level
pattern CRITICAL = 50
pattern FATAL :: Level
pattern FATAL = 40
pattern WARNING :: Level
pattern WARNING = 30
pattern INFO :: Level
pattern INFO = 20
pattern DEBUG :: Level
pattern DEBUG = 10
pattern NOTSET :: Level
pattern NOTSET = 0
defaultLevelFmt :: Level -> B.Builder ()
defaultLevelFmt level = case level of
CRITICAL -> "CRITICAL"
FATAL -> "FATAL"
WARNING -> "WARNING"
INFO -> "INFO"
DEBUG -> "DEBUG"
NOTSET -> "NOTSET"
level' -> "LEVEL" >> B.int level'
debug :: HasCallStack => B.Builder () -> IO ()
debug = otherLevel_ DEBUG False callStack
info :: HasCallStack => B.Builder () -> IO ()
info = otherLevel_ INFO False callStack
warning :: HasCallStack => B.Builder () -> IO ()
warning = otherLevel_ WARNING False callStack
fatal :: HasCallStack => B.Builder () -> IO ()
fatal = otherLevel_ FATAL True callStack
critical :: HasCallStack => B.Builder () -> IO ()
critical = otherLevel_ CRITICAL True callStack
otherLevel :: HasCallStack
=> Level
-> Bool
-> B.Builder ()
-> IO ()
otherLevel level flushNow bu = otherLevel_ level flushNow callStack bu
otherLevel_ :: Level -> Bool -> CallStack -> B.Builder () -> IO ()
otherLevel_ level flushNow cstack bu = do
logger <- getDefaultLogger
otherLevelTo_ level flushNow cstack logger bu
debugTo :: HasCallStack => Logger -> B.Builder () -> IO ()
debugTo = otherLevelTo_ DEBUG False callStack
infoTo :: HasCallStack => Logger -> B.Builder () -> IO ()
infoTo = otherLevelTo_ INFO False callStack
warningTo :: HasCallStack => Logger -> B.Builder () -> IO ()
warningTo = otherLevelTo_ WARNING False callStack
fatalTo :: HasCallStack => Logger -> B.Builder () -> IO ()
fatalTo = otherLevelTo_ FATAL True callStack
otherLevelTo :: HasCallStack
=> Logger
-> Level
-> Bool
-> B.Builder ()
-> IO ()
otherLevelTo logger level flushNow =
otherLevelTo_ level flushNow callStack logger
otherLevelTo_ :: Level -> Bool -> CallStack -> Logger -> B.Builder () -> IO ()
otherLevelTo_ level flushNow cstack logger bu = when (level >= loggerLevel logger) $ do
ts <- loggerTSCache logger
(loggerPushBuilder logger) $ (loggerFmt logger) ts level bu cstack
if flushNow
then flushLogger logger
else flushLoggerThrottled logger