{-# 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 ())
newFastLogger :: LogType' v -> IO (v -> IO (), IO ())
newFastLogger :: 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

newFastLogger1 :: LogType' v -> IO (v -> IO (), IO ())
newFastLogger1 :: 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 :: 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 (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 -> IO LoggerSet
newStdoutLoggerSet Int
bsize IO LoggerSet
-> (LoggerSet -> IO (LogStr -> IO (), IO ()))
-> IO (LogStr -> IO (), IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> IO (LogStr -> IO (), IO ())
forall (m :: * -> *).
Monad m =>
LoggerSet -> m (LogStr -> IO (), IO ())
stdLoggerInit
    LogStderr Int
bsize                -> Int -> IO LoggerSet
newStderrLoggerSet Int
bsize IO LoggerSet
-> (LoggerSet -> IO (LogStr -> IO (), IO ()))
-> IO (LogStr -> IO (), IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 (LogStr -> IO (), IO ()))
-> IO (LogStr -> IO (), IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 (m :: * -> *) a. Monad m => a -> m a
return (\v
str -> v -> IO ()
cb v
str IO () -> IO () -> IO ()
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 (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 (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 (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 (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 :: 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 (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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return (\FormattedTime -> LogStr
f -> IO FormattedTime
tgetter IO FormattedTime -> (FormattedTime -> IO ()) -> IO ()
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ( \FormattedTime -> LogStr
f -> IO FormattedTime
tgetter IO FormattedTime -> (FormattedTime -> IO ()) -> IO ()
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 (m :: * -> *) a. Monad m => a -> m a
return (\FormattedTime -> LogStr
f -> IO FormattedTime
tgetter IO FormattedTime -> (FormattedTime -> IO ()) -> IO ()
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 (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 (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 :: 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 (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 (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 (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
    getSize :: IO (Maybe Integer)
getSize = (SomeException -> IO (Maybe Integer))
-> IO (Maybe Integer) -> IO (Maybe Integer)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException e
_) -> Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing) (IO (Maybe Integer) -> IO (Maybe Integer))
-> IO (Maybe Integer) -> IO (Maybe Integer)
forall a b. (a -> b) -> a -> b
$
        -- The log file is locked by GHC.
        -- We need to get its file size by the way not using locks.
        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
    -- 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 (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 (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 (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