{-# 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 :: BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
size FilePath
file = FilePath -> IO FD
openFileFD FilePath
file IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)

-- | Creating a new 'LoggerSet' using stdout.
newStdoutLoggerSet :: BufSize -> IO LoggerSet
newStdoutLoggerSet :: BufSize -> IO LoggerSet
newStdoutLoggerSet BufSize
size = IO FD
getStdoutFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe FilePath
forall a. Maybe a
Nothing

-- | Creating a new 'LoggerSet' using stderr.
newStderrLoggerSet :: BufSize -> IO LoggerSet
newStderrLoggerSet :: BufSize -> IO LoggerSet
newStderrLoggerSet BufSize
size = IO FD
getStderrFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe FilePath
forall a. Maybe a
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 :: BufSize -> Maybe FilePath -> IO LoggerSet
newLoggerSet BufSize
size = IO LoggerSet
-> (FilePath -> IO LoggerSet) -> Maybe FilePath -> IO LoggerSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BufSize -> IO LoggerSet
newStdoutLoggerSet BufSize
size) (BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
size)

-- | Creating a new 'LoggerSet' using a FD.
newFDLoggerSet :: BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet :: BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe FilePath
mfile FD
fd = do
    BufSize
n <- IO BufSize
getNumCapabilities
    [Logger]
loggers <- BufSize -> IO Logger -> IO [Logger]
forall (m :: * -> *) a. Applicative m => BufSize -> m a -> m [a]
replicateM BufSize
n (IO Logger -> IO [Logger]) -> IO Logger -> IO [Logger]
forall a b. (a -> b) -> a -> b
$ BufSize -> IO Logger
newLogger (BufSize -> BufSize -> BufSize
forall a. Ord a => a -> a -> a
max BufSize
1 BufSize
size)
    let arr :: Array BufSize Logger
arr = (BufSize, BufSize) -> [Logger] -> Array BufSize Logger
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (BufSize
0,BufSize
nBufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
-BufSize
1) [Logger]
loggers
    IORef FD
fref <- FD -> IO (IORef FD)
forall a. a -> IO (IORef a)
newIORef FD
fd
    IO ()
flush <- DebounceSettings -> IO (IO ())
mkDebounce DebounceSettings
defaultDebounceSettings
        { debounceAction :: IO ()
debounceAction = IORef FD -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fref Array BufSize Logger
arr
        }
    LoggerSet -> IO LoggerSet
forall (m :: * -> *) a. Monad m => a -> m a
return (LoggerSet -> IO LoggerSet) -> LoggerSet -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> IORef FD -> Array BufSize Logger -> IO () -> LoggerSet
LoggerSet Maybe FilePath
mfile IORef FD
fref Array BufSize Logger
arr IO ()
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 -> LogStr -> IO ()
pushLogStr (LoggerSet Maybe FilePath
_ IORef FD
fdref Array BufSize Logger
arr IO ()
flush) LogStr
logmsg = do
    (BufSize
i, Bool
_) <- IO ThreadId
myThreadId IO ThreadId
-> (ThreadId -> IO (BufSize, Bool)) -> IO (BufSize, Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ThreadId -> IO (BufSize, Bool)
threadCapability
    -- The number of capability could be dynamically changed.
    -- So, let's check the upper boundary of the array.
    let u :: BufSize
u = (BufSize, BufSize) -> BufSize
forall a b. (a, b) -> b
snd ((BufSize, BufSize) -> BufSize) -> (BufSize, BufSize) -> BufSize
forall a b. (a -> b) -> a -> b
$ Array BufSize Logger -> (BufSize, BufSize)
forall i e. Array i e -> (i, i)
bounds Array BufSize Logger
arr
        lim :: BufSize
lim = BufSize
u BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
+ BufSize
1
        j :: BufSize
j | BufSize
i BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufSize
lim   = BufSize
i
          | Bool
otherwise = BufSize
i BufSize -> BufSize -> BufSize
forall a. Integral a => a -> a -> a
`mod` BufSize
lim
    let logger :: Logger
logger = Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
j
    IORef FD -> Logger -> LogStr -> IO ()
pushLog IORef FD
fdref Logger
logger LogStr
logmsg
    IO ()
flush

-- | Same as 'pushLogStr' but also appends a newline.
pushLogStrLn :: LoggerSet -> LogStr -> IO ()
pushLogStrLn :: LoggerSet -> LogStr -> IO ()
pushLogStrLn LoggerSet
loggerSet LogStr
logStr = LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
loggerSet (LogStr
logStr LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> 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 -> IO ()
flushLogStr (LoggerSet Maybe FilePath
_ IORef FD
fref Array BufSize Logger
arr IO ()
_) = IORef FD -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fref Array BufSize Logger
arr

flushLogStrRaw :: IORef FD -> Array Int Logger -> IO ()
flushLogStrRaw :: IORef FD -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fdref Array BufSize Logger
arr = do
    let (BufSize
l,BufSize
u) = Array BufSize Logger -> (BufSize, BufSize)
forall i e. Array i e -> (i, i)
bounds Array BufSize Logger
arr
    (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
flushIt [BufSize
l .. BufSize
u]
  where
    flushIt :: BufSize -> IO ()
flushIt BufSize
i = IORef FD -> Logger -> IO ()
flushLog IORef FD
fdref (Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i)

-- | Renewing the internal file information in 'LoggerSet'.
--   This does nothing for stdout and stderr.
renewLoggerSet :: LoggerSet -> IO ()
renewLoggerSet :: LoggerSet -> IO ()
renewLoggerSet (LoggerSet Maybe FilePath
Nothing     IORef FD
_    Array BufSize Logger
_ IO ()
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
renewLoggerSet (LoggerSet (Just FilePath
file) IORef FD
fref Array BufSize Logger
_ IO ()
_) = do
    FD
newfd <- FilePath -> IO FD
openFileFD FilePath
file
    FD
oldfd <- IORef FD -> (FD -> (FD, FD)) -> IO FD
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef FD
fref (\FD
fd -> (FD
newfd, FD
fd))
    FD -> IO ()
closeFD FD
oldfd

-- | Flushing the buffers, closing the internal file information
--   and freeing the buffers.
rmLoggerSet :: LoggerSet -> IO ()
rmLoggerSet :: LoggerSet -> IO ()
rmLoggerSet (LoggerSet Maybe FilePath
mfile IORef FD
fdref Array BufSize Logger
arr IO ()
_) = do
    let (BufSize
l,BufSize
u) = Array BufSize Logger -> (BufSize, BufSize)
forall i e. Array i e -> (i, i)
bounds Array BufSize Logger
arr
    let nums :: [BufSize]
nums = [BufSize
l .. BufSize
u]
    (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
flushIt [BufSize]
nums
    (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
freeIt [BufSize]
nums
    FD
fd <- IORef FD -> IO FD
forall a. IORef a -> IO a
readIORef IORef FD
fdref
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
mfile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FD -> IO ()
closeFD FD
fd
  where
    flushIt :: BufSize -> IO ()
flushIt BufSize
i = IORef FD -> Logger -> IO ()
flushLog IORef FD
fdref (Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i)
    freeIt :: BufSize -> IO ()
freeIt BufSize
i = do
        let (Logger BufSize
_ MVar Buffer
mbuf IORef LogStr
_) = Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i
        MVar Buffer -> IO Buffer
forall a. MVar a -> IO a
takeMVar MVar Buffer
mbuf IO Buffer -> (Buffer -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Buffer -> IO ()
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 :: LogType' v -> IO (v -> IO (), IO ())
newFastLogger 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 BufSize
bsize                -> BufSize -> IO LoggerSet
newStdoutLoggerSet BufSize
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 BufSize
bsize                -> BufSize -> IO LoggerSet
newStderrLoggerSet BufSize
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 BufSize
bsize       -> BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
bsize 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 BufSize
bsize            -> FileLogSpec -> BufSize -> IO (LogStr -> IO (), IO ())
rotateLoggerInit FileLogSpec
fspec BufSize
bsize
    LogFileTimedRotate TimedFileLogSpec
fspec BufSize
bsize -> TimedFileLogSpec -> BufSize -> IO (LogStr -> IO (), IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec BufSize
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 -> BufSize -> IO (LogStr -> IO (), IO ())
rotateLoggerInit FileLogSpec
fspec BufSize
bsize = do
        LoggerSet
lgrset <- BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
bsize (FilePath -> IO LoggerSet) -> FilePath -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$ FileLogSpec -> FilePath
log_file FileLogSpec
fspec
        IORef BufSize
ref <- BufSize -> IO (IORef BufSize)
forall a. a -> IO (IORef a)
newIORef (BufSize
0 :: Int)
        MVar ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
        let logger :: LogStr -> IO ()
logger LogStr
str = do
                BufSize
cnt <- IORef BufSize -> IO BufSize
decrease IORef BufSize
ref
                LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
lgrset LogStr
str
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufSize
cnt BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
<= BufSize
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerSet -> FileLogSpec -> IORef BufSize -> MVar () -> IO ()
tryRotate LoggerSet
lgrset FileLogSpec
fspec IORef BufSize
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 -> BufSize -> IO (LogStr -> IO (), IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec BufSize
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 <- BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
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 :: 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 BufSize
bsize                -> BufSize -> IO LoggerSet
newStdoutLoggerSet BufSize
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 BufSize
bsize                -> BufSize -> IO LoggerSet
newStderrLoggerSet BufSize
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 BufSize
bsize       -> BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
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 BufSize
bsize            -> FileLogSpec -> BufSize -> IO (TimedFastLogger, IO ())
rotateLoggerInit FileLogSpec
fspec BufSize
bsize
    LogFileTimedRotate TimedFileLogSpec
fspec BufSize
bsize -> TimedFileLogSpec -> BufSize -> IO (TimedFastLogger, IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec BufSize
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 -> BufSize -> IO (TimedFastLogger, IO ())
rotateLoggerInit FileLogSpec
fspec BufSize
bsize = do
        LoggerSet
lgrset <- BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
bsize (FilePath -> IO LoggerSet) -> FilePath -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$ FileLogSpec -> FilePath
log_file FileLogSpec
fspec
        IORef BufSize
ref <- BufSize -> IO (IORef BufSize)
forall a. a -> IO (IORef a)
newIORef (BufSize
0 :: Int)
        MVar ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
        let logger :: TimedFastLogger
logger FormattedTime -> LogStr
f = do
                BufSize
cnt <- IORef BufSize -> IO BufSize
decrease IORef BufSize
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 (BufSize
cnt BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
<= BufSize
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerSet -> FileLogSpec -> IORef BufSize -> MVar () -> IO ()
tryRotate LoggerSet
lgrset FileLogSpec
fspec IORef BufSize
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 -> BufSize -> IO (TimedFastLogger, IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec BufSize
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 <- BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
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 BufSize -> IO BufSize
decrease IORef BufSize
ref = IORef BufSize -> (BufSize -> (BufSize, BufSize)) -> IO BufSize
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BufSize
ref (\BufSize
x -> (BufSize
x BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
- BufSize
1, BufSize
x BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
- BufSize
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 BufSize -> MVar () -> IO ()
tryRotate LoggerSet
lgrset FileLogSpec
spec IORef BufSize
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 BufSize -> BufSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BufSize
ref BufSize
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 BufSize -> BufSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BufSize
ref (BufSize -> IO ()) -> BufSize -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> BufSize
forall a. Num a => Integer -> a
estimate Integer
limit
                | Bool
otherwise ->
                    IORef BufSize -> BufSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BufSize
ref (BufSize -> IO ()) -> BufSize -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> BufSize
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 Maybe FilePath
current_path IORef FD
a Array BufSize Logger
b IO ()
c)) = do
        MVar LoggerSet -> LoggerSet -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar LoggerSet
mvar (LoggerSet -> IO ()) -> LoggerSet -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> IORef FD -> Array BufSize Logger -> IO () -> LoggerSet
LoggerSet (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
new_file_path) IORef FD
a Array BufSize Logger
b IO ()
c
        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 Maybe FilePath
_ IORef FD
a Array BufSize Logger
b IO ()
c)) = LoggerSet -> IO ()
renewLoggerSet (LoggerSet -> IO ()) -> LoggerSet -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> IORef FD -> Array BufSize Logger -> IO () -> LoggerSet
LoggerSet (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
new_file_path) IORef FD
a Array BufSize Logger
b IO ()
c
    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