{-# LANGUAGE LambdaCase #-}
module Z.IO.Logger
(
Logger
, LoggerConfig(..)
, defaultLoggerConfig
, defaultJSONLoggerConfig
, setDefaultLogger
, getDefaultLogger
, flushDefaultLogger
, withDefaultLogger
, newLogger
, newStdLogger
, newFileLogger
, debug
, info
, warning
, fatal
, critical
, otherLevel
, debugTo
, infoTo
, warningTo
, fatalTo
, otherLevelTo
, LogFormatter, defaultFmt, defaultColoredFmt, defaultJSONFmt
, defaultFmtCallStack
, defaultLevelFmt
, Level
, pattern DEBUG
, pattern INFO
, pattern WARNING
, pattern FATAL
, pattern CRITICAL
, pattern NOTSET
) where
import Control.Concurrent.MVar
import Control.Monad
import Data.Bits ((.|.))
import Data.IORef
import Foreign.C.Types (CInt (..))
import GHC.Conc.Sync (ThreadId (..), myThreadId)
import GHC.Exts (ThreadId#)
import GHC.Stack
import System.IO.Unsafe (unsafePerformIO)
import qualified Z.Data.Builder as B
import qualified Z.Data.CBytes as CB
import qualified Z.Data.JSON.Builder as JB
import qualified Z.Data.Vector.Base as V
import Z.IO.Buffered
import Z.IO.Exception
import qualified Z.IO.FileSystem as ZF
import Z.IO.LowResTimer
import Z.IO.Resource
import Z.IO.StdStream
import Z.IO.StdStream.Ansi (AnsiColor (..), color)
import Z.IO.Time
type LogFormatter = B.Builder ()
-> Level
-> B.Builder ()
-> CallStack
-> ThreadId
-> B.Builder ()
data Logger = Logger
(Level -> Bool -> CallStack -> B.Builder () -> IO ())
(IO ())
instance Semigroup Logger where
Logger Level -> Bool -> CallStack -> Builder () -> IO ()
log1 IO ()
flush1 <> :: Logger -> Logger -> Logger
<> Logger Level -> Bool -> CallStack -> Builder () -> IO ()
log2 IO ()
flush2 = (Level -> Bool -> CallStack -> Builder () -> IO ())
-> IO () -> Logger
Logger
(\ Level
l Bool
b CallStack
cs Builder ()
bu -> Level -> Bool -> CallStack -> Builder () -> IO ()
log1 Level
l Bool
b CallStack
cs Builder ()
bu forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Level -> Bool -> CallStack -> Builder () -> IO ()
log2 Level
l Bool
b CallStack
cs Builder ()
bu)
(IO ()
flush1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flush2)
data LoggerConfig = LoggerConfig
{ LoggerConfig -> Level
loggerMinFlushInterval :: {-# UNPACK #-} !Int
, LoggerConfig -> Level
loggerLineBufSize :: {-# UNPACK #-} !Int
, LoggerConfig -> Level
loggerLevel :: {-# UNPACK #-} !Level
, LoggerConfig -> LogFormatter
loggerFormatter :: LogFormatter
}
defaultLoggerConfig :: LoggerConfig
{-# INLINABLE defaultLoggerConfig #-}
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig = Level -> Level -> Level -> LogFormatter -> LoggerConfig
LoggerConfig Level
1 Level
240 Level
NOTSET LogFormatter
defaultFmt
defaultJSONLoggerConfig :: LoggerConfig
{-# INLINABLE defaultJSONLoggerConfig #-}
defaultJSONLoggerConfig :: LoggerConfig
defaultJSONLoggerConfig = Level -> Level -> Level -> LogFormatter -> LoggerConfig
LoggerConfig Level
5 Level
1000 Level
NOTSET LogFormatter
defaultJSONFmt
defaultTSCache :: IO (B.Builder ())
{-# NOINLINE defaultTSCache #-}
defaultTSCache :: IO (Builder ())
defaultTSCache = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
forall a. Level -> IO a -> IO (IO a)
throttle Level
1 forall a b. (a -> b) -> a -> b
$ do
SystemTime
t <- HasCallStack => IO SystemTime
getSystemTime'
CBytes -> Builder ()
CB.toBuilder 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
{-# INLINABLE newLogger #-}
newLogger :: LoggerConfig -> MVar BufferedOutput -> IO Logger
newLogger LoggerConfig{Level
LogFormatter
loggerFormatter :: LogFormatter
loggerLevel :: Level
loggerLineBufSize :: Level
loggerMinFlushInterval :: Level
loggerFormatter :: LoggerConfig -> LogFormatter
loggerLevel :: LoggerConfig -> Level
loggerLineBufSize :: LoggerConfig -> Level
loggerMinFlushInterval :: LoggerConfig -> Level
..} MVar BufferedOutput
oLock = do
IORef [Bytes]
logsRef <- forall a. a -> IO (IORef a)
newIORef []
let flush :: IO ()
flush = HasCallStack => MVar BufferedOutput -> IORef [Bytes] -> IO ()
flushLogIORef MVar BufferedOutput
oLock IORef [Bytes]
logsRef
IO ()
throttledFlush <- Level -> IO () -> IO (IO ())
throttleTrailing_ Level
loggerMinFlushInterval IO ()
flush
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Level -> Bool -> CallStack -> Builder () -> IO ())
-> IO () -> Logger
Logger (\ Level
level Bool
flushNow CallStack
cstack Builder ()
bu ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Level
level forall a. Ord a => a -> a -> Bool
>= Level
loggerLevel) forall a b. (a -> b) -> a -> b
$ do
Builder ()
ts <- IO (Builder ())
defaultTSCache
ThreadId
tid <- IO ThreadId
myThreadId
(IORef [Bytes] -> Level -> Builder () -> IO ()
pushLogIORef IORef [Bytes]
logsRef Level
loggerLineBufSize) forall a b. (a -> b) -> a -> b
$ LogFormatter
loggerFormatter Builder ()
ts Level
level Builder ()
bu CallStack
cstack ThreadId
tid
if Bool
flushNow then IO ()
flush else IO ()
throttledFlush
) IO ()
flush
newStdLogger :: LoggerConfig -> IO Logger
{-# INLINABLE newStdLogger #-}
newStdLogger :: LoggerConfig -> IO Logger
newStdLogger LoggerConfig
config = LoggerConfig -> MVar BufferedOutput -> IO Logger
newLogger LoggerConfig
config MVar BufferedOutput
stderrBuf
newFileLogger :: LoggerConfig -> CB.CBytes -> IO Logger
{-# INLINABLE newFileLogger #-}
newFileLogger :: LoggerConfig -> CBytes -> IO Logger
newFileLogger LoggerConfig
config CBytes
path = do
let res :: Resource File
res = HasCallStack => CBytes -> CInt -> CInt -> Resource File
ZF.initFile CBytes
path (CInt
ZF.O_CREAT forall a. Bits a => a -> a -> a
.|. CInt
ZF.O_RDWR forall a. Bits a => a -> a -> a
.|. CInt
ZF.O_APPEND) CInt
ZF.DEFAULT_FILE_MODE
(File
file, IO ()
_closeFunc) <- forall a. Resource a -> IO (a, IO ())
acquire Resource File
res
MVar BufferedOutput
oLock <- forall a. a -> IO (MVar a)
newMVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall o. Output o => o -> IO BufferedOutput
newBufferedOutput File
file
LoggerConfig -> MVar BufferedOutput -> IO Logger
newLogger LoggerConfig
config MVar BufferedOutput
oLock
pushLogIORef :: IORef [V.Bytes]
-> Int
-> B.Builder ()
-> IO ()
{-# INLINABLE pushLogIORef #-}
pushLogIORef :: IORef [Bytes] -> Level -> Builder () -> IO ()
pushLogIORef IORef [Bytes]
logsRef Level
loggerLineBufSize Builder ()
b = do
let !bs :: Bytes
bs = forall a. Level -> Builder a -> Bytes
B.buildWith Level
loggerLineBufSize Builder ()
b
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (v :: * -> *) a. Vec v a => v a -> Bool
V.null Bytes
bs) forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Bytes]
logsRef (\ [Bytes]
bss -> (Bytes
bsforall a. a -> [a] -> [a]
:[Bytes]
bss, ()))
flushLogIORef :: HasCallStack => MVar BufferedOutput -> IORef [V.Bytes] -> IO ()
{-# INLINABLE flushLogIORef #-}
flushLogIORef :: HasCallStack => MVar BufferedOutput -> IORef [Bytes] -> IO ()
flushLogIORef MVar BufferedOutput
oLock IORef [Bytes]
logsRef =
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar BufferedOutput
oLock forall a b. (a -> b) -> a -> b
$ \ BufferedOutput
o -> do
[Bytes]
bss <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Bytes]
logsRef (\ [Bytes]
bss -> ([], [Bytes]
bss))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse [Bytes]
bss) (HasCallStack => BufferedOutput -> Bytes -> IO ()
writeBuffer BufferedOutput
o)
HasCallStack => BufferedOutput -> IO ()
flushBuffer BufferedOutput
o
defaultFmt :: LogFormatter
{-# INLINABLE defaultFmt #-}
defaultFmt :: LogFormatter
defaultFmt Builder ()
ts Level
level Builder ()
content CallStack
cstack (ThreadId ThreadId#
tid#) = do
Builder () -> Builder ()
B.square (Level -> Builder ()
defaultLevelFmt Level
level)
Builder () -> Builder ()
B.square Builder ()
ts
Builder () -> Builder ()
B.square forall a b. (a -> b) -> a -> b
$ CallStack -> Builder ()
defaultFmtCallStack CallStack
cstack
Builder () -> Builder ()
B.square forall a b. (a -> b) -> a -> b
$ Builder ()
"thread#" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. (Integral a, Bounded a) => a -> Builder ()
B.int (ThreadId# -> CInt
getThreadId ThreadId#
tid#)
Builder ()
content
Char -> Builder ()
B.char8 Char
'\n'
defaultColoredFmt :: LogFormatter
{-# INLINABLE defaultColoredFmt #-}
defaultColoredFmt :: LogFormatter
defaultColoredFmt Builder ()
ts Level
level Builder ()
content CallStack
cstack (ThreadId ThreadId#
tid#) = 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 forall a b. (a -> b) -> a -> b
$ CallStack -> Builder ()
defaultFmtCallStack CallStack
cstack
Builder () -> Builder ()
B.square forall a b. (a -> b) -> a -> b
$ Builder ()
"thread#" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. (Integral a, Bounded a) => a -> Builder ()
B.int (ThreadId# -> CInt
getThreadId ThreadId#
tid#)
Builder ()
content
Char -> Builder ()
B.char8 Char
'\n'
defaultJSONFmt :: LogFormatter
{-# INLINABLE defaultJSONFmt #-}
defaultJSONFmt :: LogFormatter
defaultJSONFmt Builder ()
ts Level
level Builder ()
content CallStack
cstack (ThreadId ThreadId#
tid#) = do
Builder () -> Builder ()
B.curly forall a b. (a -> b) -> a -> b
$ do
Text
"level" Text -> Builder () -> Builder ()
`JB.kv` Builder () -> Builder ()
B.quotes (Level -> Builder ()
defaultLevelFmt Level
level)
Builder ()
B.comma
Text
"time" Text -> Builder () -> Builder ()
`JB.kv` Builder () -> Builder ()
B.quotes Builder ()
ts
Builder ()
B.comma
Text
"loc" Text -> Builder () -> Builder ()
`JB.kv` Builder () -> Builder ()
B.quotes (CallStack -> Builder ()
defaultFmtCallStack CallStack
cstack)
Builder ()
B.comma
Text
"thead" Text -> Builder () -> Builder ()
`JB.kv` forall a. (Integral a, Bounded a) => a -> Builder ()
B.int (ThreadId# -> CInt
getThreadId ThreadId#
tid#)
Builder ()
B.comma
Text
"content" Text -> Builder () -> Builder ()
`JB.kv` Text -> Builder ()
JB.string (forall a. Builder a -> Text
B.unsafeBuildText Builder ()
content)
Char -> Builder ()
B.char8 Char
'\n'
defaultFmtCallStack :: CallStack -> B.Builder ()
{-# INLINABLE defaultFmtCallStack #-}
defaultFmtCallStack :: CallStack -> Builder ()
defaultFmtCallStack CallStack
cs =
case forall a. [a] -> [a]
reverse 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
':'
forall a. (Integral a, Bounded a) => a -> Builder ()
B.int (SrcLoc -> Level
srcLocStartLine SrcLoc
loc)
Char -> Builder ()
B.char8 Char
':'
forall a. (Integral a, Bounded a) => a -> Builder ()
B.int (SrcLoc -> Level
srcLocStartCol SrcLoc
loc)
globalLogger :: IORef Logger
{-# NOINLINE globalLogger #-}
globalLogger :: IORef Logger
globalLogger = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$
forall a. a -> IO (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LoggerConfig -> IO Logger
newStdLogger LoggerConfig
defaultLoggerConfig{
loggerFormatter :: LogFormatter
loggerFormatter = (if StdStream -> Bool
isStdStreamTTY StdStream
stderr then LogFormatter
defaultColoredFmt else LogFormatter
defaultFmt)
}
setDefaultLogger :: Logger -> IO ()
{-# INLINABLE setDefaultLogger #-}
setDefaultLogger :: Logger -> IO ()
setDefaultLogger !Logger
logger = forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Logger
globalLogger Logger
logger
getDefaultLogger :: IO Logger
{-# INLINABLE getDefaultLogger #-}
getDefaultLogger :: IO Logger
getDefaultLogger = forall a. IORef a -> IO a
readIORef IORef Logger
globalLogger
flushDefaultLogger :: IO ()
{-# INLINABLE flushDefaultLogger #-}
flushDefaultLogger :: IO ()
flushDefaultLogger = do
(Logger Level -> Bool -> CallStack -> Builder () -> IO ()
_ IO ()
flush) <- IO Logger
getDefaultLogger
IO ()
flush
withDefaultLogger :: IO () -> IO ()
{-# INLINABLE withDefaultLogger #-}
withDefaultLogger :: IO () -> IO ()
withDefaultLogger = (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 -> ((# #) -> r) -> ((# #) -> r) -> r
CRITICAL = 50
pattern FATAL :: Level
pattern $bFATAL :: Level
$mFATAL :: forall {r}. Level -> ((# #) -> r) -> ((# #) -> r) -> r
FATAL = 40
pattern WARNING :: Level
pattern $bWARNING :: Level
$mWARNING :: forall {r}. Level -> ((# #) -> r) -> ((# #) -> r) -> r
WARNING = 30
pattern INFO :: Level
pattern $bINFO :: Level
$mINFO :: forall {r}. Level -> ((# #) -> r) -> ((# #) -> r) -> r
INFO = 20
pattern DEBUG :: Level
pattern $bDEBUG :: Level
$mDEBUG :: forall {r}. Level -> ((# #) -> r) -> ((# #) -> r) -> r
DEBUG = 10
pattern NOTSET :: Level
pattern $bNOTSET :: Level
$mNOTSET :: forall {r}. Level -> ((# #) -> r) -> ((# #) -> r) -> r
NOTSET = 0
defaultLevelFmt :: Level -> B.Builder ()
{-# INLINABLE defaultLevelFmt #-}
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" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. (Integral a, Bounded a) => a -> Builder ()
B.int Level
level'
debug :: HasCallStack => B.Builder () -> IO ()
{-# INLINABLE debug #-}
debug :: HasCallStack => Builder () -> IO ()
debug = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
DEBUG Bool
False HasCallStack => CallStack
callStack
info :: HasCallStack => B.Builder () -> IO ()
{-# INLINABLE info #-}
info :: HasCallStack => Builder () -> IO ()
info = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
INFO Bool
False HasCallStack => CallStack
callStack
warning :: HasCallStack => B.Builder () -> IO ()
{-# INLINABLE warning #-}
warning :: HasCallStack => Builder () -> IO ()
warning = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
WARNING Bool
False HasCallStack => CallStack
callStack
fatal :: HasCallStack => B.Builder () -> IO ()
{-# INLINABLE fatal #-}
fatal :: HasCallStack => Builder () -> IO ()
fatal = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
FATAL Bool
True HasCallStack => CallStack
callStack
critical :: HasCallStack => B.Builder () -> IO ()
{-# INLINABLE critical #-}
critical :: HasCallStack => Builder () -> IO ()
critical = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
CRITICAL Bool
True HasCallStack => CallStack
callStack
otherLevel :: HasCallStack
=> Level
-> Bool
-> B.Builder ()
-> IO ()
{-# INLINABLE otherLevel #-}
otherLevel :: HasCallStack => Level -> Bool -> Builder () -> IO ()
otherLevel Level
level Bool
flushNow Builder ()
bu = Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
level Bool
flushNow HasCallStack => CallStack
callStack Builder ()
bu
otherLevel_ :: Level -> Bool -> CallStack -> B.Builder () -> IO ()
{-# INLINABLE otherLevel_ #-}
otherLevel_ :: Level -> Bool -> CallStack -> Builder () -> IO ()
otherLevel_ Level
level Bool
flushNow CallStack
cstack Builder ()
bu = do
(Logger Level -> Bool -> CallStack -> Builder () -> IO ()
f IO ()
_) <- IO Logger
getDefaultLogger
Level -> Bool -> CallStack -> Builder () -> IO ()
f Level
level Bool
flushNow CallStack
cstack Builder ()
bu
debugTo :: HasCallStack => Logger -> B.Builder () -> IO ()
{-# INLINABLE debugTo #-}
debugTo :: HasCallStack => Logger -> Builder () -> IO ()
debugTo = Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
DEBUG Bool
False HasCallStack => CallStack
callStack
infoTo :: HasCallStack => Logger -> B.Builder () -> IO ()
{-# INLINABLE infoTo #-}
infoTo :: HasCallStack => Logger -> Builder () -> IO ()
infoTo = Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
INFO Bool
False HasCallStack => CallStack
callStack
warningTo :: HasCallStack => Logger -> B.Builder () -> IO ()
{-# INLINABLE warningTo #-}
warningTo :: HasCallStack => Logger -> Builder () -> IO ()
warningTo = Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
WARNING Bool
False HasCallStack => CallStack
callStack
fatalTo :: HasCallStack => Logger -> B.Builder () -> IO ()
{-# INLINABLE fatalTo #-}
fatalTo :: HasCallStack => Logger -> Builder () -> IO ()
fatalTo = Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
FATAL Bool
True HasCallStack => CallStack
callStack
otherLevelTo :: HasCallStack
=> Logger
-> Level
-> Bool
-> B.Builder ()
-> IO ()
{-# INLINABLE otherLevelTo #-}
otherLevelTo :: HasCallStack => Logger -> Level -> Bool -> Builder () -> IO ()
otherLevelTo Logger
logger Level
level Bool
flushNow = Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
level Bool
flushNow HasCallStack => CallStack
callStack Logger
logger
otherLevelTo_ :: Level -> Bool -> CallStack -> Logger -> B.Builder () -> IO ()
{-# INLINABLE otherLevelTo_ #-}
otherLevelTo_ :: Level -> Bool -> CallStack -> Logger -> Builder () -> IO ()
otherLevelTo_ Level
level Bool
flushNow CallStack
cs (Logger Level -> Bool -> CallStack -> Builder () -> IO ()
f IO ()
_) = Level -> Bool -> CallStack -> Builder () -> IO ()
f Level
level Bool
flushNow CallStack
cs
foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt