fast-logger-3.0.0: System/Log/FastLogger.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
-- | This module provides a fast logging system which
-- scales on multicore environments (i.e. +RTS -N\<x\>).
--
-- Note: This library does not guarantee correct ordering of log messages
-- when program is run on more than one core thus users
-- should rely more on message timestamps than on their order in the
-- log.
module System.Log.FastLogger (
-- * Creating a logger set
LoggerSet
, newFileLoggerSet
, newStdoutLoggerSet
, newStderrLoggerSet
, newLoggerSet
-- * Buffer size
, BufSize
, defaultBufSize
-- * Renewing and removing a logger set
, renewLoggerSet
, rmLoggerSet
-- * Log messages
, LogStr
, ToLogStr(..)
, fromLogStr
, logStrLength
-- * Writing a log message
, pushLogStr
, pushLogStrLn
-- * Flushing buffered log messages
, flushLogStr
-- * FastLogger
, FastLogger
, TimedFastLogger
, LogType'(..), LogType
, newFastLogger
, withFastLogger
, newTimedFastLogger
, withTimedFastLogger
-- * Date cache
, module System.Log.FastLogger.Date
-- * File rotation
, module System.Log.FastLogger.File
-- * Types
, module System.Log.FastLogger.Types
) where
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceAction)
import Control.Concurrent (getNumCapabilities, myThreadId, threadCapability, takeMVar, MVar, newMVar, tryTakeMVar, putMVar)
import Control.Exception (handle, SomeException(..), bracket)
import Data.Array (Array, listArray, (!), bounds)
import System.EasyFile (getFileSize)
import System.Log.FastLogger.Date
import System.Log.FastLogger.File
import System.Log.FastLogger.FileIO
import System.Log.FastLogger.IO
import System.Log.FastLogger.Imports
import System.Log.FastLogger.LogStr
import System.Log.FastLogger.Logger
import System.Log.FastLogger.Types
----------------------------------------------------------------
-- | A set of loggers.
-- The number of loggers is the capabilities of GHC RTS.
-- You can specify it with \"+RTS -N\<x\>\".
-- A buffer is prepared for each capability.
data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD) (Array Int Logger) (IO ())
-- | Creating a new 'LoggerSet' using a file.
newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet size file = openFileFD file >>= newFDLoggerSet size (Just file)
-- | Creating a new 'LoggerSet' using stdout.
newStdoutLoggerSet :: BufSize -> IO LoggerSet
newStdoutLoggerSet size = getStdoutFD >>= newFDLoggerSet size Nothing
-- | Creating a new 'LoggerSet' using stderr.
newStderrLoggerSet :: BufSize -> IO LoggerSet
newStderrLoggerSet size = getStderrFD >>= newFDLoggerSet size Nothing
{-# DEPRECATED newLoggerSet "Use newFileLoggerSet etc instead" #-}
-- | Creating a new 'LoggerSet'.
-- If 'Nothing' is specified to the second argument,
-- stdout is used.
-- Please note that the minimum 'BufSize' is 1.
newLoggerSet :: BufSize -> Maybe FilePath -> IO LoggerSet
newLoggerSet size = maybe (newStdoutLoggerSet size) (newFileLoggerSet size)
-- | Creating a new 'LoggerSet' using a FD.
newFDLoggerSet :: BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet size mfile fd = do
n <- getNumCapabilities
loggers <- replicateM n $ newLogger (max 1 size)
let arr = listArray (0,n-1) loggers
fref <- newIORef fd
flush <- mkDebounce defaultDebounceSettings
{ debounceAction = flushLogStrRaw fref arr
}
return $ LoggerSet mfile fref arr flush
-- | Writing a log message to the corresponding buffer.
-- If the buffer becomes full, the log messages in the buffer
-- are written to its corresponding file, stdout, or stderr.
pushLogStr :: LoggerSet -> LogStr -> IO ()
pushLogStr (LoggerSet _ fdref arr flush) logmsg = do
(i, _) <- myThreadId >>= threadCapability
-- The number of capability could be dynamically changed.
-- So, let's check the upper boundary of the array.
let u = snd $ bounds arr
lim = u + 1
j | i < lim = i
| otherwise = i `mod` lim
let logger = arr ! j
pushLog fdref logger logmsg
flush
-- | Same as 'pushLogStr' but also appends a newline.
pushLogStrLn :: LoggerSet -> LogStr -> IO ()
pushLogStrLn loggerSet logStr = pushLogStr loggerSet (logStr <> "\n")
-- | Flushing log messages in buffers.
-- This function must be called explicitly when the program is
-- being terminated.
--
-- Note: Since version 2.1.6, this function does not need to be
-- explicitly called, as every push includes an auto-debounced flush
-- courtesy of the auto-update package. Since version 2.2.2, this
-- function can be used to force flushing outside of the debounced
-- flush calls.
flushLogStr :: LoggerSet -> IO ()
flushLogStr (LoggerSet _ fref arr _) = flushLogStrRaw fref arr
flushLogStrRaw :: IORef FD -> Array Int Logger -> IO ()
flushLogStrRaw fdref arr = do
let (l,u) = bounds arr
mapM_ flushIt [l .. u]
where
flushIt i = flushLog fdref (arr ! i)
-- | Renewing the internal file information in 'LoggerSet'.
-- This does nothing for stdout and stderr.
renewLoggerSet :: LoggerSet -> IO ()
renewLoggerSet (LoggerSet Nothing _ _ _) = return ()
renewLoggerSet (LoggerSet (Just file) fref _ _) = do
newfd <- openFileFD file
oldfd <- atomicModifyIORef' fref (\fd -> (newfd, fd))
closeFD oldfd
-- | Flushing the buffers, closing the internal file information
-- and freeing the buffers.
rmLoggerSet :: LoggerSet -> IO ()
rmLoggerSet (LoggerSet mfile fdref arr _) = do
let (l,u) = bounds arr
let nums = [l .. u]
mapM_ flushIt nums
mapM_ freeIt nums
fd <- readIORef fdref
when (isJust mfile) $ closeFD fd
where
flushIt i = flushLog fdref (arr ! i)
freeIt i = do
let (Logger _ mbuf _) = arr ! i
takeMVar mbuf >>= freeBuffer
----------------------------------------------------------------
-- | 'FastLogger' simply log 'logStr'.
type FastLogger = LogStr -> IO ()
-- | 'TimedFastLogger' pass 'FormattedTime' to callback and simply log its result.
-- this can be used to customize how to log timestamp.
--
-- Usually, one would write a wrapper on top of 'TimedFastLogger', for example:
--
-- @
-- {-# LANGUAGE OverloadedStrings #-}
--
-- log :: TimedFastLogger -> LogStr -> IO ()
-- log logger msg = logger (\time -> toLogStr (show time) <> " " <> msg <> "\n")
-- @
type TimedFastLogger = (FormattedTime -> LogStr) -> IO ()
type LogType = LogType' LogStr
-- | Logger Type.
data LogType' a where
LogNone :: LogType' LogStr -- ^ No logging.
LogStdout :: BufSize -> LogType' LogStr
-- ^ Logging to stdout.
-- 'BufSize' is a buffer size
-- for each capability.
LogStderr :: BufSize -> LogType' LogStr
-- ^ Logging to stderr.
-- 'BufSize' is a buffer size
-- for each capability.
LogFileNoRotate :: FilePath -> BufSize -> LogType' LogStr
-- ^ Logging to a file.
-- 'BufSize' is a buffer size
-- for each capability.
LogFile :: FileLogSpec -> BufSize -> LogType' LogStr
-- ^ Logging to a file.
-- 'BufSize' is a buffer size
-- for each capability.
-- File rotation is done on-demand.
LogFileTimedRotate :: TimedFileLogSpec -> BufSize -> LogType' LogStr -- ^ Logging to a file.
-- 'BufSize' is a buffer size
-- for each capability.
-- Rotation happens based on check specified
-- in 'TimedFileLogSpec'.
LogCallback :: (v -> IO ()) -> IO () -> LogType' v -- ^ Logging with a log and flush action.
-- run flush after log each message.
-- | Initialize a 'FastLogger' without attaching timestamp
-- a tuple of logger and clean up action are returned.
newFastLogger :: LogType' v -> IO (v -> IO (), IO ())
newFastLogger typ = case typ of
LogNone -> return (const noOp, noOp)
LogStdout bsize -> newStdoutLoggerSet bsize >>= stdLoggerInit
LogStderr bsize -> newStderrLoggerSet bsize >>= stdLoggerInit
LogFileNoRotate fp bsize -> newFileLoggerSet bsize fp >>= fileLoggerInit
LogFile fspec bsize -> rotateLoggerInit fspec bsize
LogFileTimedRotate fspec bsize -> timedRotateLoggerInit fspec bsize
LogCallback cb flush -> return (\str -> cb str >> flush, noOp)
where
stdLoggerInit lgrset = return (pushLogStr lgrset, rmLoggerSet lgrset)
fileLoggerInit lgrset = return (pushLogStr lgrset, rmLoggerSet lgrset)
rotateLoggerInit fspec bsize = do
lgrset <- newFileLoggerSet bsize $ log_file fspec
ref <- newIORef (0 :: Int)
mvar <- newMVar ()
let logger str = do
cnt <- decrease ref
pushLogStr lgrset str
when (cnt <= 0) $ tryRotate lgrset fspec ref mvar
return (logger, rmLoggerSet lgrset)
timedRotateLoggerInit fspec bsize = do
cache <- newTimeCache $ timed_timefmt fspec
now <- cache
lgrset <- newFileLoggerSet bsize $ prefixTime now $ timed_log_file fspec
ref <- newIORef now
mvar <- newMVar lgrset
let logger str = do
ct <- cache
updated <- updateTime (timed_same_timeframe fspec) ref ct
when updated $ tryTimedRotate fspec ct mvar
pushLogStr lgrset str
return (logger, rmLoggerSet lgrset)
-- | 'bracket' version of 'newFastLogger'
withFastLogger :: LogType -> (FastLogger -> IO a) -> IO a
withFastLogger typ log' = bracket (newFastLogger typ) snd (log' . fst)
-- | Initialize a 'FastLogger' with timestamp attached to each message.
-- a tuple of logger and clean up action are returned.
newTimedFastLogger ::
IO FormattedTime -- ^ How do we get 'FormattedTime'?
-- "System.Log.FastLogger.Date" provide cached formatted time.
-> LogType -> IO (TimedFastLogger, IO ())
newTimedFastLogger tgetter typ = case typ of
LogNone -> return (const noOp, noOp)
LogStdout bsize -> newStdoutLoggerSet bsize >>= stdLoggerInit
LogStderr bsize -> newStderrLoggerSet bsize >>= stdLoggerInit
LogFileNoRotate fp bsize -> newFileLoggerSet bsize fp >>= fileLoggerInit
LogFile fspec bsize -> rotateLoggerInit fspec bsize
LogFileTimedRotate fspec bsize -> timedRotateLoggerInit fspec bsize
LogCallback cb flush -> return (\f -> tgetter >>= cb . f >> flush, noOp)
where
stdLoggerInit lgrset = return ( \f -> tgetter >>= pushLogStr lgrset . f, rmLoggerSet lgrset)
fileLoggerInit lgrset = return (\f -> tgetter >>= pushLogStr lgrset . f, rmLoggerSet lgrset)
rotateLoggerInit fspec bsize = do
lgrset <- newFileLoggerSet bsize $ log_file fspec
ref <- newIORef (0 :: Int)
mvar <- newMVar ()
let logger f = do
cnt <- decrease ref
t <- tgetter
pushLogStr lgrset (f t)
when (cnt <= 0) $ tryRotate lgrset fspec ref mvar
return (logger, rmLoggerSet lgrset)
timedRotateLoggerInit fspec bsize = do
cache <- newTimeCache $ timed_timefmt fspec
now <- cache
lgrset <- newFileLoggerSet bsize $ prefixTime now $ timed_log_file fspec
ref <- newIORef now
mvar <- newMVar lgrset
let logger f = do
ct <- cache
updated <- updateTime (timed_same_timeframe fspec) ref ct
when updated $ tryTimedRotate fspec ct mvar
t <- tgetter
pushLogStr lgrset (f t)
return (logger, rmLoggerSet lgrset)
-- | 'bracket' version of 'newTimeFastLogger'
withTimedFastLogger :: IO FormattedTime -> LogType -> (TimedFastLogger -> IO a) -> IO a
withTimedFastLogger tgetter typ log' = bracket (newTimedFastLogger tgetter typ) snd (log' . fst)
----------------------------------------------------------------
noOp :: IO ()
noOp = return ()
decrease :: IORef Int -> IO Int
decrease ref = atomicModifyIORef' ref (\x -> (x - 1, x - 1))
-- updateTime returns whether the timeframe has changed
updateTime :: (FormattedTime -> FormattedTime -> Bool) -> IORef FormattedTime -> FormattedTime -> IO Bool
updateTime cmp ref newTime = atomicModifyIORef' ref (\x -> (newTime, not $ cmp x newTime))
tryRotate :: LoggerSet -> FileLogSpec -> IORef Int -> MVar () -> IO ()
tryRotate lgrset spec ref mvar = bracket lock unlock rotateFiles
where
lock = tryTakeMVar mvar
unlock Nothing = return ()
unlock _ = putMVar mvar ()
rotateFiles Nothing = return ()
rotateFiles _ = do
msiz <- getSize
case msiz of
-- A file is not available.
-- So, let's set a big value to the counter so that
-- this function is not called frequently.
Nothing -> writeIORef ref 1000000
Just siz
| siz > limit -> do
rotate spec
renewLoggerSet lgrset
writeIORef ref $ estimate limit
| otherwise ->
writeIORef ref $ estimate (limit - siz)
file = log_file spec
limit = log_file_size spec
getSize = handle (\(SomeException _) -> return Nothing) $
-- The log file is locked by GHC.
-- We need to get its file size by the way not using locks.
Just . fromIntegral <$> getFileSize file
-- 200 is an ad-hoc value for the length of log line.
estimate x = fromInteger (x `div` 200)
tryTimedRotate :: TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO ()
tryTimedRotate spec now mvar = bracket lock unlock rotateFiles
where
lock = tryTakeMVar mvar
unlock Nothing = return ()
unlock (Just (LoggerSet current_path a b c)) = do
putMVar mvar $ LoggerSet (Just new_file_path) a b c
case current_path of
Nothing -> return ()
Just path -> timed_post_process spec path
rotateFiles Nothing = return ()
rotateFiles (Just (LoggerSet _ a b c)) = renewLoggerSet $ LoggerSet (Just new_file_path) a b c
new_file_path = prefixTime now $ timed_log_file spec