{-# 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 (bracket)
import System.EasyFile (getFileSize)
import qualified System.IO.Error as E

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.
        --
        --   On Windows this needs the native I\/O manager
        --   (@+RTS --io-manager=native@).  Rotation renames the
        --   log file while it is still open, which the
        --   descriptor the POSIX subsystem opens there is not
        --   shared for; the rename is refused and the file
        --   stops rotating.  Nothing is lost -- the log keeps
        --   being written to the one file, past the size asked
        --   for.
    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 :: forall v. LogType' v -> IO (v -> IO (), IO ())
newFastLogger LogType' v
typ = Maybe Int -> LogType' v -> IO (v -> IO (), IO ())
forall v. Maybe Int -> LogType' v -> IO (v -> IO (), IO ())
newFastLoggerCore Maybe Int
forall a. Maybe a
Nothing LogType' v
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 :: forall v. LogType' v -> IO (v -> IO (), IO ())
newFastLogger1 LogType' v
typ = Maybe Int -> LogType' v -> IO (v -> IO (), IO ())
forall v. Maybe Int -> LogType' v -> IO (v -> IO (), IO ())
newFastLoggerCore (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) LogType' v
typ

newFastLoggerCore :: Maybe Int -> LogType' v -> IO (v -> IO (), IO ())
newFastLoggerCore :: forall v. Maybe Int -> LogType' v -> IO (v -> IO (), IO ())
newFastLoggerCore Maybe Int
mn LogType' v
typ = case LogType' v
typ of
    LogType' v
LogNone -> (v -> IO (), IO ()) -> IO (v -> IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> v -> IO ()
forall a b. a -> b -> a
const IO ()
noOp, IO ()
noOp)
    LogStdout Int
bsize -> Int -> Maybe Int -> IO LoggerSet
newStdoutLoggerSetN Int
bsize Maybe Int
mn IO LoggerSet
-> (LoggerSet -> IO (v -> IO (), IO ())) -> IO (v -> IO (), IO ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> IO (v -> IO (), IO ())
LoggerSet -> IO (LogStr -> IO (), IO ())
forall {m :: * -> *}.
Monad m =>
LoggerSet -> m (LogStr -> IO (), IO ())
stdLoggerInit
    LogStderr Int
bsize -> Int -> Maybe Int -> IO LoggerSet
newStderrLoggerSetN Int
bsize Maybe Int
mn IO LoggerSet
-> (LoggerSet -> IO (v -> IO (), IO ())) -> IO (v -> IO (), IO ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> IO (v -> IO (), IO ())
LoggerSet -> IO (LogStr -> IO (), IO ())
forall {m :: * -> *}.
Monad m =>
LoggerSet -> m (LogStr -> IO (), IO ())
stdLoggerInit
    LogFileNoRotate FilePath
fp Int
bsize -> Int -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN Int
bsize Maybe Int
mn FilePath
fp IO LoggerSet
-> (LoggerSet -> IO (v -> IO (), IO ())) -> IO (v -> IO (), IO ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> IO (v -> IO (), IO ())
LoggerSet -> IO (LogStr -> IO (), IO ())
forall {m :: * -> *}.
Monad m =>
LoggerSet -> m (LogStr -> IO (), IO ())
fileLoggerInit
    LogFile FileLogSpec
fspec Int
bsize -> FileLogSpec -> Int -> IO (LogStr -> IO (), IO ())
rotateLoggerInit FileLogSpec
fspec Int
bsize
    LogFileTimedRotate TimedFileLogSpec
fspec Int
bsize -> TimedFileLogSpec -> Int -> IO (LogStr -> IO (), IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec Int
bsize
    LogCallback v -> IO ()
cb IO ()
flush -> (v -> IO (), IO ()) -> IO (v -> IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (\v
str -> v -> IO ()
cb v
str IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flush, IO ()
noOp)
  where
    stdLoggerInit :: LoggerSet -> m (LogStr -> IO (), IO ())
stdLoggerInit LoggerSet
lgrset = (LogStr -> IO (), IO ()) -> m (LogStr -> IO (), IO ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
lgrset, LoggerSet -> IO ()
rmLoggerSet LoggerSet
lgrset)
    fileLoggerInit :: LoggerSet -> m (LogStr -> IO (), IO ())
fileLoggerInit LoggerSet
lgrset = (LogStr -> IO (), IO ()) -> m (LogStr -> IO (), IO ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
lgrset, LoggerSet -> IO ()
rmLoggerSet LoggerSet
lgrset)
    rotateLoggerInit :: FileLogSpec -> Int -> IO (LogStr -> IO (), IO ())
rotateLoggerInit FileLogSpec
fspec Int
bsize = do
        LoggerSet
lgrset <- Int -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN Int
bsize Maybe Int
mn (FilePath -> IO LoggerSet) -> FilePath -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$ FileLogSpec -> FilePath
log_file FileLogSpec
fspec
        IORef Int
ref <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
        MVar ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
        let logger :: LogStr -> IO ()
logger LogStr
str = do
                Int
cnt <- IORef Int -> IO Int
decrease IORef Int
ref
                LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
lgrset LogStr
str
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerSet -> FileLogSpec -> IORef Int -> MVar () -> IO ()
tryRotate LoggerSet
lgrset FileLogSpec
fspec IORef Int
ref MVar ()
mvar
        (LogStr -> IO (), IO ()) -> IO (LogStr -> IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogStr -> IO ()
logger, LoggerSet -> IO ()
rmLoggerSet LoggerSet
lgrset)
    timedRotateLoggerInit :: TimedFileLogSpec -> Int -> IO (LogStr -> IO (), IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec Int
bsize = do
        IO FormattedTime
cache <- FormattedTime -> IO (IO FormattedTime)
newTimeCache (FormattedTime -> IO (IO FormattedTime))
-> FormattedTime -> IO (IO FormattedTime)
forall a b. (a -> b) -> a -> b
$ TimedFileLogSpec -> FormattedTime
timed_timefmt TimedFileLogSpec
fspec
        FormattedTime
now <- IO FormattedTime
cache
        LoggerSet
lgrset <- Int -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN Int
bsize Maybe Int
mn (FilePath -> IO LoggerSet) -> FilePath -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$ FormattedTime -> FilePath -> FilePath
prefixTime FormattedTime
now (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ TimedFileLogSpec -> FilePath
timed_log_file TimedFileLogSpec
fspec
        IORef FormattedTime
ref <- FormattedTime -> IO (IORef FormattedTime)
forall a. a -> IO (IORef a)
newIORef FormattedTime
now
        MVar LoggerSet
mvar <- LoggerSet -> IO (MVar LoggerSet)
forall a. a -> IO (MVar a)
newMVar LoggerSet
lgrset
        let logger :: LogStr -> IO ()
logger LogStr
str = do
                FormattedTime
ct <- IO FormattedTime
cache
                Bool
updated <- (FormattedTime -> FormattedTime -> Bool)
-> IORef FormattedTime -> FormattedTime -> IO Bool
updateTime (TimedFileLogSpec -> FormattedTime -> FormattedTime -> Bool
timed_same_timeframe TimedFileLogSpec
fspec) IORef FormattedTime
ref FormattedTime
ct
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
updated (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO ()
tryTimedRotate TimedFileLogSpec
fspec FormattedTime
ct MVar LoggerSet
mvar
                LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
lgrset LogStr
str
        (LogStr -> IO (), IO ()) -> IO (LogStr -> IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogStr -> IO ()
logger, LoggerSet -> IO ()
rmLoggerSet LoggerSet
lgrset)

-- | 'bracket' version of 'newFastLogger'
withFastLogger :: LogType -> (FastLogger -> IO a) -> IO a
withFastLogger :: forall a. LogType -> ((LogStr -> IO ()) -> IO a) -> IO a
withFastLogger LogType
typ (LogStr -> IO ()) -> IO a
log' = IO (LogStr -> IO (), IO ())
-> ((LogStr -> IO (), IO ()) -> IO ())
-> ((LogStr -> IO (), IO ()) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (LogType -> IO (LogStr -> IO (), IO ())
forall v. LogType' v -> IO (v -> IO (), IO ())
newFastLogger LogType
typ) (LogStr -> IO (), IO ()) -> IO ()
forall a b. (a, b) -> b
snd ((LogStr -> IO ()) -> IO a
log' ((LogStr -> IO ()) -> IO a)
-> ((LogStr -> IO (), IO ()) -> LogStr -> IO ())
-> (LogStr -> IO (), IO ())
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogStr -> IO (), IO ()) -> LogStr -> IO ()
forall a b. (a, b) -> a
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 :: IO FormattedTime -> LogType -> IO (TimedFastLogger, IO ())
newTimedFastLogger IO FormattedTime
tgetter LogType
typ = case LogType
typ of
    LogType
LogNone -> (TimedFastLogger, IO ()) -> IO (TimedFastLogger, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> TimedFastLogger
forall a b. a -> b -> a
const IO ()
noOp, IO ()
noOp)
    LogStdout Int
bsize -> Int -> IO LoggerSet
newStdoutLoggerSet Int
bsize IO LoggerSet
-> (LoggerSet -> IO (TimedFastLogger, IO ()))
-> IO (TimedFastLogger, IO ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> IO (TimedFastLogger, IO ())
stdLoggerInit
    LogStderr Int
bsize -> Int -> IO LoggerSet
newStderrLoggerSet Int
bsize IO LoggerSet
-> (LoggerSet -> IO (TimedFastLogger, IO ()))
-> IO (TimedFastLogger, IO ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> IO (TimedFastLogger, IO ())
stdLoggerInit
    LogFileNoRotate FilePath
fp Int
bsize -> Int -> FilePath -> IO LoggerSet
newFileLoggerSet Int
bsize FilePath
fp IO LoggerSet
-> (LoggerSet -> IO (TimedFastLogger, IO ()))
-> IO (TimedFastLogger, IO ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> IO (TimedFastLogger, IO ())
fileLoggerInit
    LogFile FileLogSpec
fspec Int
bsize -> FileLogSpec -> Int -> IO (TimedFastLogger, IO ())
rotateLoggerInit FileLogSpec
fspec Int
bsize
    LogFileTimedRotate TimedFileLogSpec
fspec Int
bsize -> TimedFileLogSpec -> Int -> IO (TimedFastLogger, IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec Int
bsize
    LogCallback LogStr -> IO ()
cb IO ()
flush -> (TimedFastLogger, IO ()) -> IO (TimedFastLogger, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (\FormattedTime -> LogStr
f -> IO FormattedTime
tgetter IO FormattedTime -> (FormattedTime -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogStr -> IO ()
cb (LogStr -> IO ())
-> (FormattedTime -> LogStr) -> FormattedTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormattedTime -> LogStr
f IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flush, IO ()
noOp)
  where
    stdLoggerInit :: LoggerSet -> IO (TimedFastLogger, IO ())
stdLoggerInit LoggerSet
lgrset = (TimedFastLogger, IO ()) -> IO (TimedFastLogger, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (\FormattedTime -> LogStr
f -> IO FormattedTime
tgetter IO FormattedTime -> (FormattedTime -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
lgrset (LogStr -> IO ())
-> (FormattedTime -> LogStr) -> FormattedTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormattedTime -> LogStr
f, LoggerSet -> IO ()
rmLoggerSet LoggerSet
lgrset)
    fileLoggerInit :: LoggerSet -> IO (TimedFastLogger, IO ())
fileLoggerInit LoggerSet
lgrset = (TimedFastLogger, IO ()) -> IO (TimedFastLogger, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (\FormattedTime -> LogStr
f -> IO FormattedTime
tgetter IO FormattedTime -> (FormattedTime -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
lgrset (LogStr -> IO ())
-> (FormattedTime -> LogStr) -> FormattedTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormattedTime -> LogStr
f, LoggerSet -> IO ()
rmLoggerSet LoggerSet
lgrset)
    rotateLoggerInit :: FileLogSpec -> Int -> IO (TimedFastLogger, IO ())
rotateLoggerInit FileLogSpec
fspec Int
bsize = do
        LoggerSet
lgrset <- Int -> FilePath -> IO LoggerSet
newFileLoggerSet Int
bsize (FilePath -> IO LoggerSet) -> FilePath -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$ FileLogSpec -> FilePath
log_file FileLogSpec
fspec
        IORef Int
ref <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
        MVar ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
        let logger :: TimedFastLogger
logger FormattedTime -> LogStr
f = do
                Int
cnt <- IORef Int -> IO Int
decrease IORef Int
ref
                FormattedTime
t <- IO FormattedTime
tgetter
                LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
lgrset (FormattedTime -> LogStr
f FormattedTime
t)
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerSet -> FileLogSpec -> IORef Int -> MVar () -> IO ()
tryRotate LoggerSet
lgrset FileLogSpec
fspec IORef Int
ref MVar ()
mvar
        (TimedFastLogger, IO ()) -> IO (TimedFastLogger, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedFastLogger
logger, LoggerSet -> IO ()
rmLoggerSet LoggerSet
lgrset)
    timedRotateLoggerInit :: TimedFileLogSpec -> Int -> IO (TimedFastLogger, IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec Int
bsize = do
        IO FormattedTime
cache <- FormattedTime -> IO (IO FormattedTime)
newTimeCache (FormattedTime -> IO (IO FormattedTime))
-> FormattedTime -> IO (IO FormattedTime)
forall a b. (a -> b) -> a -> b
$ TimedFileLogSpec -> FormattedTime
timed_timefmt TimedFileLogSpec
fspec
        FormattedTime
now <- IO FormattedTime
cache
        LoggerSet
lgrset <- Int -> FilePath -> IO LoggerSet
newFileLoggerSet Int
bsize (FilePath -> IO LoggerSet) -> FilePath -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$ FormattedTime -> FilePath -> FilePath
prefixTime FormattedTime
now (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ TimedFileLogSpec -> FilePath
timed_log_file TimedFileLogSpec
fspec
        IORef FormattedTime
ref <- FormattedTime -> IO (IORef FormattedTime)
forall a. a -> IO (IORef a)
newIORef FormattedTime
now
        MVar LoggerSet
mvar <- LoggerSet -> IO (MVar LoggerSet)
forall a. a -> IO (MVar a)
newMVar LoggerSet
lgrset
        let logger :: TimedFastLogger
logger FormattedTime -> LogStr
f = do
                FormattedTime
ct <- IO FormattedTime
cache
                Bool
updated <- (FormattedTime -> FormattedTime -> Bool)
-> IORef FormattedTime -> FormattedTime -> IO Bool
updateTime (TimedFileLogSpec -> FormattedTime -> FormattedTime -> Bool
timed_same_timeframe TimedFileLogSpec
fspec) IORef FormattedTime
ref FormattedTime
ct
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
updated (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO ()
tryTimedRotate TimedFileLogSpec
fspec FormattedTime
ct MVar LoggerSet
mvar
                FormattedTime
t <- IO FormattedTime
tgetter
                LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
lgrset (FormattedTime -> LogStr
f FormattedTime
t)
        (TimedFastLogger, IO ()) -> IO (TimedFastLogger, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedFastLogger
logger, LoggerSet -> IO ()
rmLoggerSet LoggerSet
lgrset)

-- | 'bracket' version of 'newTimeFastLogger'
withTimedFastLogger
    :: IO FormattedTime -> LogType -> (TimedFastLogger -> IO a) -> IO a
withTimedFastLogger :: forall a.
IO FormattedTime -> LogType -> (TimedFastLogger -> IO a) -> IO a
withTimedFastLogger IO FormattedTime
tgetter LogType
typ TimedFastLogger -> IO a
log' = IO (TimedFastLogger, IO ())
-> ((TimedFastLogger, IO ()) -> IO ())
-> ((TimedFastLogger, IO ()) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (IO FormattedTime -> LogType -> IO (TimedFastLogger, IO ())
newTimedFastLogger IO FormattedTime
tgetter LogType
typ) (TimedFastLogger, IO ()) -> IO ()
forall a b. (a, b) -> b
snd (TimedFastLogger -> IO a
log' (TimedFastLogger -> IO a)
-> ((TimedFastLogger, IO ()) -> TimedFastLogger)
-> (TimedFastLogger, IO ())
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimedFastLogger, IO ()) -> TimedFastLogger
forall a b. (a, b) -> a
fst)

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

noOp :: IO ()
noOp :: IO ()
noOp = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

decrease :: IORef Int -> IO Int
decrease :: IORef Int -> IO Int
decrease IORef Int
ref = IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
ref (\Int
x -> (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

-- updateTime returns whether the timeframe has changed
updateTime
    :: (FormattedTime -> FormattedTime -> Bool)
    -> IORef FormattedTime
    -> FormattedTime
    -> IO Bool
updateTime :: (FormattedTime -> FormattedTime -> Bool)
-> IORef FormattedTime -> FormattedTime -> IO Bool
updateTime FormattedTime -> FormattedTime -> Bool
cmp IORef FormattedTime
ref FormattedTime
newTime = IORef FormattedTime
-> (FormattedTime -> (FormattedTime, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef FormattedTime
ref (\FormattedTime
x -> (FormattedTime
newTime, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FormattedTime -> FormattedTime -> Bool
cmp FormattedTime
x FormattedTime
newTime))

tryRotate :: LoggerSet -> FileLogSpec -> IORef Int -> MVar () -> IO ()
tryRotate :: LoggerSet -> FileLogSpec -> IORef Int -> MVar () -> IO ()
tryRotate LoggerSet
lgrset FileLogSpec
spec IORef Int
ref MVar ()
mvar = IO (Maybe ())
-> (Maybe () -> IO ()) -> (Maybe () -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Maybe ())
lock Maybe () -> IO ()
unlock Maybe () -> IO ()
rotateFiles
  where
    lock :: IO (Maybe ())
lock = MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
mvar
    unlock :: Maybe () -> IO ()
unlock Maybe ()
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    unlock Maybe ()
_ = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
    rotateFiles :: Maybe () -> IO ()
rotateFiles Maybe ()
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    rotateFiles Maybe ()
_ = do
        Maybe Integer
msiz <- IO (Maybe Integer)
getSize
        case Maybe Integer
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.
            Maybe Integer
Nothing -> IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref Int
1000000
            Just Integer
siz
                | Integer
siz Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
limit -> do
                    FileLogSpec -> IO ()
rotate FileLogSpec
spec
                    LoggerSet -> IO ()
renewLoggerSet LoggerSet
lgrset
                    IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall {a}. Num a => Integer -> a
estimate Integer
limit
                | Bool
otherwise ->
                    IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall {a}. Num a => Integer -> a
estimate (Integer
limit Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
siz)
    file :: FilePath
file = FileLogSpec -> FilePath
log_file FileLogSpec
spec
    limit :: Integer
limit = FileLogSpec -> Integer
log_file_size FileLogSpec
spec
    -- The log file is locked by GHC.
    -- We need to get its file size by the way not using locks.
    getSize :: IO (Maybe Integer)
getSize =
        (Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (Word64 -> Integer) -> Word64 -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Maybe Integer) -> IO Word64 -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Word64
getFileSize FilePath
file) IO (Maybe Integer)
-> (IOError -> IO (Maybe Integer)) -> IO (Maybe Integer)
forall a. IO a -> (IOError -> IO a) -> IO a
`E.catchIOError` \IOError
_ -> Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing

    -- 200 is an ad-hoc value for the length of log line.
    estimate :: Integer -> a
estimate Integer
x = Integer -> a
forall {a}. Num a => Integer -> a
fromInteger (Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
200)

tryTimedRotate :: TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO ()
tryTimedRotate :: TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO ()
tryTimedRotate TimedFileLogSpec
spec FormattedTime
now MVar LoggerSet
mvar = IO (Maybe LoggerSet)
-> (Maybe LoggerSet -> IO ())
-> (Maybe LoggerSet -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Maybe LoggerSet)
lock Maybe LoggerSet -> IO ()
unlock Maybe LoggerSet -> IO ()
rotateFiles
  where
    lock :: IO (Maybe LoggerSet)
lock = MVar LoggerSet -> IO (Maybe LoggerSet)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar LoggerSet
mvar
    unlock :: Maybe LoggerSet -> IO ()
unlock Maybe LoggerSet
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    unlock (Just LoggerSet
lgrset) = do
        let (LoggerSet
newlgrset, Maybe FilePath
current_path) = LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
replaceLoggerSet LoggerSet
lgrset FilePath
new_file_path
        MVar LoggerSet -> LoggerSet -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar LoggerSet
mvar LoggerSet
newlgrset
        case Maybe FilePath
current_path of
            Maybe FilePath
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just FilePath
path -> TimedFileLogSpec -> FilePath -> IO ()
timed_post_process TimedFileLogSpec
spec FilePath
path
    rotateFiles :: Maybe LoggerSet -> IO ()
rotateFiles Maybe LoggerSet
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    rotateFiles (Just LoggerSet
lgrset) = do
        let (LoggerSet
newlgrset, Maybe FilePath
_) = LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
replaceLoggerSet LoggerSet
lgrset FilePath
new_file_path
        LoggerSet -> IO ()
renewLoggerSet LoggerSet
newlgrset
    new_file_path :: FilePath
new_file_path = FormattedTime -> FilePath -> FilePath
prefixTime FormattedTime
now (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ TimedFileLogSpec -> FilePath
timed_log_file TimedFileLogSpec
spec