module Z.IO.Logger
(
Logger(..)
, LoggerConfig(..)
, defaultLoggerConfig
, setDefaultLogger
, getDefaultLogger
, flushDefaultLogger
, withDefaultLogger
, newLogger
, newColoredLogger
, debug
, info
, warn
, fatal
, otherLevel
, debugTo
, infoTo
, warnTo
, fatalTo
, otherLevelTo
, defaultTSCache
, defaultFmtCallStack
, LogFormatter, defaultFmt, coloredFmt
, flushLog
) where
import Control.Monad
import Z.Data.Vector.Base as V
import Z.IO.LowResTimer
import Z.IO.StdStream
import Z.IO.StdStream.Ansi (color, AnsiColor(..))
import Z.IO.Buffered
import System.IO.Unsafe (unsafePerformIO)
import Z.IO.Exception
import Z.IO.Time
import Data.IORef
import Control.Concurrent.MVar
import GHC.Stack
import qualified Z.Data.Builder as B
import qualified Z.Data.CBytes as CB
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
}
data LoggerConfig = LoggerConfig
{ loggerMinFlushInterval :: {-# UNPACK #-} !Int
, loggerLineBufSize :: {-# UNPACK #-} !Int
, loggerShowDebug :: Bool
}
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig = LoggerConfig 1 128 True
defaultTSCache :: IO (B.Builder ())
{-# NOINLINE defaultTSCache #-}
defaultTSCache = unsafePerformIO $ do
throttle 1 $ do
t <- getSystemTime
CB.toBuilder <$> formatSystemTime simpleDateFormat t
flushLog :: (HasCallStack, Output o) => MVar (BufferedOutput o) -> IORef [V.Bytes] -> IO ()
flushLog oLock bList =
withMVar oLock $ \ o -> do
bss <- atomicModifyIORef' bList (\ bss -> ([], bss))
forM_ (reverse bss) (writeBuffer o)
flushBuffer o
newLogger :: Output o
=> LoggerConfig
-> MVar (BufferedOutput o)
-> IO Logger
newLogger LoggerConfig{..} oLock = do
bList <- newIORef []
let flush = flushLog oLock bList
throttledFlush <- throttleTrailing_ loggerMinFlushInterval flush
return $ Logger (pushLog bList) flush throttledFlush defaultTSCache
(defaultFmt loggerShowDebug)
where
pushLog bList b = do
let !bs = B.buildBytesWith loggerLineBufSize b
atomicModifyIORef' bList (\ bss -> (bs:bss, ()))
newColoredLogger :: LoggerConfig -> IO Logger
newColoredLogger LoggerConfig{..} = do
bList <- newIORef []
let flush = flushLog stderrBuf bList
throttledFlush <- throttleTrailing_ loggerMinFlushInterval flush
return $ Logger (pushLog bList) flush throttledFlush defaultTSCache
(if isStdStreamTTY stderr then coloredFmt loggerShowDebug
else defaultFmt loggerShowDebug)
where
pushLog bList b = do
let !bs = B.buildBytesWith loggerLineBufSize b
atomicModifyIORef' bList (\ bss -> (bs:bss, ()))
defaultFmt :: Bool
-> LogFormatter
defaultFmt showdebug ts level content cstack = when (showdebug || level /= "DEBUG") $ do
B.square (CB.toBuilder level)
B.square ts
B.square $ defaultFmtCallStack cstack
content
coloredFmt :: Bool
-> LogFormatter
coloredFmt showdebug ts level content cstack = when (showdebug || level /= "DEBUG") $ do
let blevel = CB.toBuilder level
B.square (case level of
"DEBUG" -> color Cyan blevel
"WARN" -> color Yellow blevel
"FATAL" -> color Red blevel
_ -> blevel)
B.square ts
B.square $ defaultFmtCallStack cstack
content
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 = CB.CBytes
debug :: HasCallStack => B.Builder () -> IO ()
debug = otherLevel_ "DEBUG" False callStack
info :: HasCallStack => B.Builder () -> IO ()
info = otherLevel_ "INFO" False callStack
warn :: HasCallStack => B.Builder () -> IO ()
warn = otherLevel_ "WARN" False callStack
fatal :: HasCallStack => B.Builder () -> IO ()
fatal = otherLevel_ "FATAL" 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
warnTo :: HasCallStack => Logger -> B.Builder () -> IO ()
warnTo = otherLevelTo_ "WARN" 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 = do
ts <- loggerTSCache logger
(loggerPushBuilder logger) $ (loggerFmt logger) ts level bu cstack
if flushNow
then flushLogger logger
else flushLoggerThrottled logger