FastLogger.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}

-- | 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 (
    -- * FastLogger
    FastLogger,
    LogType,
    LogType' (..),
    newFastLogger,
    newFastLogger1,
    withFastLogger,

    -- * Timed FastLogger
    TimedFastLogger,
    newTimedFastLogger,
    withTimedFastLogger,

    -- * Log messages
    LogStr,
    ToLogStr (..),
    fromLogStr,
    logStrLength,

    -- * Buffer size
    BufSize,
    defaultBufSize,

    -- * LoggerSet
    module System.Log.FastLogger.LoggerSet,

    -- * Date cache
    module System.Log.FastLogger.Date,

    -- * File rotation
    module System.Log.FastLogger.File,

    -- * Types
    module System.Log.FastLogger.Types,
) where

import Control.Concurrent (MVar, newMVar, putMVar, tryTakeMVar)
import Control.Exception (SomeException (..), bracket, handle)
import System.EasyFile (getFileSize)

import System.Log.FastLogger.Date
import System.Log.FastLogger.File
import System.Log.FastLogger.IO
import System.Log.FastLogger.Imports
import System.Log.FastLogger.LogStr
import System.Log.FastLogger.LoggerSet
import System.Log.FastLogger.Types

----------------------------------------------------------------

-- | '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.
-- This type signature should be read as:
--
-- > newFastLogger :: LogType -> IO (FastLogger, IO ())
--
-- This logger uses `numCapabilities` many buffers, and thus
-- does not provide time-ordered output.
-- For time-ordered output, use `newFastLogger1`.
newFastLogger :: LogType' v -> IO (v -> IO (), IO ())
newFastLogger typ = newFastLoggerCore Nothing typ

-- | Like `newFastLogger`, but creating a logger that uses only 1
-- internal builder. This scales less on multi-core machines and
-- consumes more memory because of an internal queue but provides
-- time-ordered output.
newFastLogger1 :: LogType' v -> IO (v -> IO (), IO ())
newFastLogger1 typ = newFastLoggerCore (Just 1) typ

newFastLoggerCore :: Maybe Int -> LogType' v -> IO (v -> IO (), IO ())
newFastLoggerCore mn typ = case typ of
    LogNone -> return (const noOp, noOp)
    LogStdout bsize -> newStdoutLoggerSetN bsize mn >>= stdLoggerInit
    LogStderr bsize -> newStderrLoggerSetN bsize mn >>= stdLoggerInit
    LogFileNoRotate fp bsize -> newFileLoggerSetN bsize mn 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 <- newFileLoggerSetN bsize mn $ 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 <- newFileLoggerSetN bsize mn $ 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 lgrset) = do
        let (newlgrset, current_path) = replaceLoggerSet lgrset new_file_path
        putMVar mvar newlgrset
        case current_path of
            Nothing -> return ()
            Just path -> timed_post_process spec path
    rotateFiles Nothing = return ()
    rotateFiles (Just lgrset) = do
        let (newlgrset, _) = replaceLoggerSet lgrset new_file_path
        renewLoggerSet newlgrset
    new_file_path = prefixTime now $ timed_log_file spec