{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

{-|
Module      : Z.IO.Logger
Description : High performance logger
Copyright   : (c) Dong Han, 2017-2018
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

Simple, high performance logger. The design choice of this logger is biased towards simplicity instead of generlization:

    * All log functions lives in 'IO'.
    * By default this logger is connected to stderr, use 'setStdLogger' to customize.
    * When logging each thread will build log 'Builder's into a small 'V.Bytes' with line buffer
      instead of leaving all 'Builder's to the flushing thread:
        * Logger won't keep heap data for too long simply because they're referenced by log's 'Builder'.
        * Each logging thread only need perform a CAS to prepend log 'V.Bytes' into a list,
          which reduces contention.
        * Each log call is atomic, Logging order is preserved under concurrent settings.

Flushing is automatic and throttled for 'debug', 'info', 'warn' to boost performance, but a 'fatal' log will always flush logger's buffer.  This could lead to a problem that if main thread exits too early logs may missed, to add a flushing when program exits, use 'withStdLogger' like:

@
import Z.IO.Logger

main :: IO ()
main = withStdLogger $ do
    ....
    debug "..."   -- So that this log won't be missed
    ...
@
-}

module Z.IO.Logger
  ( -- * A simple Logger type
    Logger
  , LoggerConfig(..)
  , newLogger
  , loggerFlush
  , setStdLogger
  , getStdLogger
  , withStdLogger
    -- * logging functions
  , debug
  , info
  , warn
  , fatal
  , otherLevel
    -- * logging functions with specific logger
  , 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 ()                -- ^ flush logger's buffer to output device
    , 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 -- ^ Minimal flush interval, see Notes on 'debug'
    , LoggerConfig -> IO (Builder ())
loggerTsCache          :: IO (B.Builder ())   -- ^ A IO action return a formatted date/time string
    , LoggerConfig -> Int
loggerLineBufSize      :: {-# UNPACK #-} !Int -- ^ Buffer size to build each log/line
    , LoggerConfig -> Bool
loggerShowDebug        :: Bool                -- ^ Set to 'False' to filter debug logs
    , LoggerConfig -> Bool
loggerShowTS           :: Bool                -- ^ Set to 'False' to disable auto data/time string prepending
    }

-- | A default logger config with
--
--   * debug ON
--   * 0.1s minimal flush interval
--   * defaultTSCache
--   * line buffer size 128 bytes
--   * show debug True
--   * show timestamp True
--   * 'BufferedOutput' buffer size equals to 'V.defaultChunkSize'.
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig :: LoggerConfig
defaultLoggerConfig = Int -> IO (Builder ()) -> Int -> Bool -> Bool -> LoggerConfig
LoggerConfig Int
1 IO (Builder ())
defaultTSCache Int
128 Bool
True Bool
True

-- | A default timestamp cache with format @%Y-%m-%dT%H:%M:%S%Z@
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

-- | Make a new logger
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

-- | Change the global logger.
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

-- | Get the global logger.
getStdLogger :: IO Logger
getStdLogger :: IO Logger
getStdLogger = IORef Logger -> IO Logger
forall a. IORef a -> IO a
readIORef IORef Logger
globalLogger

-- | Manually flush stderr logger.
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, ()))

-- | Flush stderr logger when program exits.
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 ()      -- ^ log level
           -> Bool              -- ^ flush immediately?
           -> B.Builder ()      -- ^ log content
           -> 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 ()      -- ^ log level
               -> Bool              -- ^ flush immediately?
               -> B.Builder ()      -- ^ log content
               -> 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