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 (
  -- * 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, tryTakeMVar, putMVar)
import Control.Exception (handle, SomeException(..), bracket)
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