module Z.IO.Logger
(
Logger(..)
, LoggerConfig(..)
, setStdLogger
, getStdLogger
, withStdLogger
, newLogger
, debug
, info
, warn
, fatal
, otherLevel
, debugTo
, infoTo
, warnTo
, fatalTo
, otherLevelTo
, defaultTSCache
, defaultFmtCallStack
, LogFormatter, defaultFmt
, flushLog
) where
import Control.Monad
import Z.Data.Vector.Base as V
import Z.IO.LowResTimer
import Z.IO.StdStream
import Z.IO.Buffered
import System.IO.Unsafe (unsafePerformIO)
import Z.IO.Exception
import Data.IORef
import Control.Concurrent.MVar
import GHC.Stack
import qualified Z.Data.Builder as B
import qualified Data.Time as Time
type LogFormatter = Maybe (B.Builder ())
-> B.Builder ()
-> B.Builder ()
-> CallStack
-> B.Builder ()
data Logger = Logger
{ loggerPushBuilder :: B.Builder () -> IO ()
, flushLogger :: IO ()
, flushLoggerThrottled :: IO ()
, loggerTSCache :: IO (Maybe (B.Builder ()))
, loggerFmt :: LogFormatter
}
data LoggerConfig = LoggerConfig
{ loggerMinFlushInterval :: {-# UNPACK #-} !Int
, loggerLineBufSize :: {-# UNPACK #-} !Int
, loggerShowDebug :: Bool
, loggerShowTS :: Bool
, loggerShowSourceLoc :: Bool
}
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig = LoggerConfig 1 128 True True True
defaultTSCache :: IO (B.Builder ())
{-# NOINLINE defaultTSCache #-}
defaultTSCache = unsafePerformIO $ do
throttle 1 $ do
t <- Time.getCurrentTime
return . B.string8 $
Time.formatTime Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Z" 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 config oLock = do
bList <- newIORef []
let flush = flushLog oLock bList
throttledFlush <- throttleTrailing_ (loggerMinFlushInterval config) flush
return $ Logger (pushLog bList) flush throttledFlush tsCache (defaultFmt (loggerShowSourceLoc config))
where
tsCache = if (loggerShowTS config) then Just <$> defaultTSCache else pure Nothing
pushLog bList b = do
let !bs = B.buildBytesWith (loggerLineBufSize config) b
atomicModifyIORef' bList (\ bss -> (bs:bss, ()))
defaultFmt :: Bool
-> LogFormatter
defaultFmt showcstack maybeTS level content cstack = do
B.square level
forM_ maybeTS $ \ ts -> B.square ts
when showcstack (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 =<< newLogger defaultLoggerConfig stderrBuf
setStdLogger :: Logger -> IO ()
setStdLogger !logger = atomicWriteIORef globalLogger logger
getStdLogger :: IO Logger
getStdLogger = readIORef globalLogger
flushDefaultLogger :: IO ()
flushDefaultLogger = getStdLogger >>= flushLogger
withStdLogger :: IO () -> IO ()
withStdLogger = (`finally` flushDefaultLogger)
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
=> B.Builder ()
-> Bool
-> B.Builder ()
-> IO ()
otherLevel level flushNow bu = otherLevel_ level flushNow callStack bu
otherLevel_ :: B.Builder () -> Bool -> CallStack -> B.Builder () -> IO ()
otherLevel_ level flushNow cstack bu = do
logger <- getStdLogger
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
-> B.Builder ()
-> Bool
-> B.Builder ()
-> IO ()
otherLevelTo logger level flushNow =
otherLevelTo_ level flushNow callStack logger
otherLevelTo_ :: B.Builder () -> 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