{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Z.IO.Logger
(
Logger
, LoggerConfig(..)
, newLogger
, loggerFlush
, setStdLogger
, getStdLogger
, withStdLogger
, debug
, info
, warn
, fatal
, otherLevel
, debugWith
, infoWith
, warnWith
, fatalWith
, otherLevelWith
) 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 qualified Z.Data.Builder.Base as B
import qualified Data.Time as Time
data Logger = Logger
{ Logger -> IO ()
loggerFlush :: IO ()
, Logger -> IO ()
loggerThrottledFlush :: IO ()
, Logger -> IORef [Bytes]
loggerBytesList :: {-# UNPACK #-} !(IORef [V.Bytes])
, Logger -> LoggerConfig
loggerConfig :: {-# UNPACK #-} !LoggerConfig
}
data LoggerConfig = LoggerConfig
{ LoggerConfig -> Int
loggerMinFlushInterval :: {-# UNPACK #-} !Int
, LoggerConfig -> IO (Builder ())
loggerTsCache :: IO (B.Builder ())
, LoggerConfig -> Int
loggerLineBufSize :: {-# UNPACK #-} !Int
, LoggerConfig -> Bool
loggerShowDebug :: Bool
, LoggerConfig -> Bool
loggerShowTS :: Bool
}
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig = Int -> IO (Builder ()) -> Int -> Bool -> Bool -> LoggerConfig
LoggerConfig Int
1 IO (Builder ())
defaultTSCache Int
128 Bool
True Bool
True
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
Int -> IO (Builder ()) -> IO (IO (Builder ()))
forall a. Int -> IO a -> IO (IO a)
throttle Int
1 (IO (Builder ()) -> IO (IO (Builder ())))
-> IO (Builder ()) -> IO (IO (Builder ()))
forall a b. (a -> b) -> a -> b
$ do
UTCTime
t <- IO UTCTime
Time.getCurrentTime
Builder () -> IO (Builder ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder () -> IO (Builder ()))
-> (String -> Builder ()) -> String -> IO (Builder ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder ()
B.string8 (String -> IO (Builder ())) -> String -> IO (Builder ())
forall a b. (a -> b) -> a -> b
$
TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
Time.defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%Z" UTCTime
t
flushLog :: (HasCallStack, Output o) => MVar (BufferedOutput o) -> IORef [V.Bytes] -> IO ()
flushLog :: MVar (BufferedOutput o) -> IORef [Bytes] -> IO ()
flushLog MVar (BufferedOutput o)
oLock IORef [Bytes]
bList =
MVar (BufferedOutput o) -> (BufferedOutput o -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (BufferedOutput o)
oLock ((BufferedOutput o -> IO ()) -> IO ())
-> (BufferedOutput o -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BufferedOutput o
o -> do
[Bytes]
bss <- IORef [Bytes] -> ([Bytes] -> ([Bytes], [Bytes])) -> IO [Bytes]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Bytes]
bList (\ [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) (BufferedOutput o -> Bytes -> IO ()
forall o.
(HasCallStack, Output o) =>
BufferedOutput o -> Bytes -> IO ()
writeBuffer BufferedOutput o
o)
BufferedOutput o -> IO ()
forall o. (HasCallStack, Output o) => BufferedOutput o -> IO ()
flushBuffer BufferedOutput o
o
newLogger :: Output o
=> LoggerConfig
-> MVar (BufferedOutput o)
-> IO Logger
newLogger :: LoggerConfig -> MVar (BufferedOutput o) -> IO Logger
newLogger LoggerConfig
config MVar (BufferedOutput o)
oLock = do
IORef [Bytes]
bList <- [Bytes] -> IO (IORef [Bytes])
forall a. a -> IO (IORef a)
newIORef []
let flush :: IO ()
flush = MVar (BufferedOutput o) -> IORef [Bytes] -> IO ()
forall o.
(HasCallStack, Output o) =>
MVar (BufferedOutput o) -> IORef [Bytes] -> IO ()
flushLog MVar (BufferedOutput o)
oLock IORef [Bytes]
bList
IO ()
throttledFlush <- Int -> IO () -> IO (IO ())
throttleTrailing_ (LoggerConfig -> Int
loggerMinFlushInterval LoggerConfig
config) 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
$ IO () -> IO () -> IORef [Bytes] -> LoggerConfig -> Logger
Logger IO ()
flush IO ()
throttledFlush IORef [Bytes]
bList LoggerConfig
config
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 -> MVar (BufferedOutput StdStream) -> IO Logger
forall o.
Output o =>
LoggerConfig -> MVar (BufferedOutput o) -> IO Logger
newLogger LoggerConfig
defaultLoggerConfig MVar (BufferedOutput StdStream)
stderrBuf
setStdLogger :: Logger -> IO ()
setStdLogger :: Logger -> IO ()
setStdLogger !Logger
logger = IORef Logger -> Logger -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Logger
globalLogger Logger
logger
getStdLogger :: IO Logger
getStdLogger :: IO Logger
getStdLogger = IORef Logger -> IO Logger
forall a. IORef a -> IO a
readIORef IORef Logger
globalLogger
flushDefaultLogger :: IO ()
flushDefaultLogger :: IO ()
flushDefaultLogger = IO Logger
getStdLogger IO Logger -> (Logger -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Logger -> IO ()
loggerFlush
pushLog :: IORef [V.Bytes] -> Int -> B.Builder () -> IO ()
pushLog :: IORef [Bytes] -> Int -> Builder () -> IO ()
pushLog IORef [Bytes]
blist Int
bfsiz Builder ()
b = do
let !bs :: Bytes
bs = Int -> Builder () -> Bytes
forall a. Int -> Builder a -> Bytes
B.buildBytesWith Int
bfsiz Builder ()
b
IORef [Bytes] -> ([Bytes] -> ([Bytes], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Bytes]
blist (\ [Bytes]
bss -> (Bytes
bsBytes -> [Bytes] -> [Bytes]
forall a. a -> [a] -> [a]
:[Bytes]
bss, ()))
withStdLogger :: IO () -> IO ()
withStdLogger :: IO () -> IO ()
withStdLogger = (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
flushDefaultLogger)
debug :: B.Builder () -> IO ()
debug :: Builder () -> IO ()
debug = Builder () -> Bool -> Builder () -> IO ()
otherLevel Builder ()
"DEBUG" Bool
False
info :: B.Builder () -> IO ()
info :: Builder () -> IO ()
info = Builder () -> Bool -> Builder () -> IO ()
otherLevel Builder ()
"INFO" Bool
False
warn :: B.Builder () -> IO ()
warn :: Builder () -> IO ()
warn = Builder () -> Bool -> Builder () -> IO ()
otherLevel Builder ()
"WARN" Bool
False
fatal :: B.Builder () -> IO ()
fatal :: Builder () -> IO ()
fatal = Builder () -> Bool -> Builder () -> IO ()
otherLevel Builder ()
"FATAL" Bool
True
otherLevel :: B.Builder ()
-> Bool
-> B.Builder ()
-> IO ()
otherLevel :: Builder () -> Bool -> Builder () -> IO ()
otherLevel Builder ()
level Bool
flushNow Builder ()
b =
IO Logger
getStdLogger IO Logger -> (Logger -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Logger
logger -> Logger -> Builder () -> Bool -> Builder () -> IO ()
otherLevelWith Logger
logger Builder ()
level Bool
flushNow Builder ()
b
debugWith :: Logger -> B.Builder () -> IO ()
debugWith :: Logger -> Builder () -> IO ()
debugWith Logger
logger = Logger -> Builder () -> Bool -> Builder () -> IO ()
otherLevelWith Logger
logger Builder ()
"DEBUG" Bool
False
infoWith :: Logger -> B.Builder () -> IO ()
infoWith :: Logger -> Builder () -> IO ()
infoWith Logger
logger = Logger -> Builder () -> Bool -> Builder () -> IO ()
otherLevelWith Logger
logger Builder ()
"INFO" Bool
False
warnWith :: Logger -> B.Builder () -> IO ()
warnWith :: Logger -> Builder () -> IO ()
warnWith Logger
logger = Logger -> Builder () -> Bool -> Builder () -> IO ()
otherLevelWith Logger
logger Builder ()
"WARN" Bool
False
fatalWith :: Logger -> B.Builder () -> IO ()
fatalWith :: Logger -> Builder () -> IO ()
fatalWith Logger
logger = Logger -> Builder () -> Bool -> Builder () -> IO ()
otherLevelWith Logger
logger Builder ()
"FATAL" Bool
True
otherLevelWith :: Logger
-> B.Builder ()
-> Bool
-> B.Builder ()
-> IO ()
otherLevelWith :: Logger -> Builder () -> Bool -> Builder () -> IO ()
otherLevelWith Logger
logger Builder ()
level Bool
flushNow Builder ()
b = case Logger
logger of
(Logger IO ()
flush IO ()
throttledFlush IORef [Bytes]
blist (LoggerConfig Int
_ IO (Builder ())
tscache Int
lbsiz Bool
showdebug Bool
showts)) -> do
Builder ()
ts <- if Bool
showts then IO (Builder ())
tscache else Builder () -> IO (Builder ())
forall (m :: * -> *) a. Monad m => a -> m a
return Builder ()
""
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showdebug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IORef [Bytes] -> Int -> Builder () -> IO ()
pushLog IORef [Bytes]
blist Int
lbsiz (Builder () -> IO ()) -> Builder () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Char -> Builder ()
B.char8 Char
'['
Builder ()
level
Char -> Builder ()
B.char8 Char
']'
Char -> Builder ()
B.char8 Char
' '
Bool -> Builder () -> Builder ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showts (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ Builder ()
ts Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Builder ()
B.char8 Char
' '
Builder ()
b
Char -> Builder ()
B.char8 Char
'\n'
if Bool
flushNow then IO ()
flush else IO ()
throttledFlush