{-# 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 size :: BufSize
size file :: 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 size :: 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 size :: 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 size :: 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 size :: BufSize
size mfile :: Maybe FilePath
mfile fd :: 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 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 (0,BufSize
nBufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
-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 _ fdref :: IORef FD
fdref arr :: Array BufSize Logger
arr flush :: IO ()
flush) logmsg :: LogStr
logmsg = do
    (i :: BufSize
i, _) <- 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
+ 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
loggerSet logStr :: LogStr
logStr = LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
loggerSet (LogStr
logStr LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> "\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 _ fref :: IORef FD
fref arr :: Array BufSize Logger
arr _) = 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 fdref :: IORef FD
fdref arr :: Array BufSize Logger
arr = do
    let (l :: BufSize
l,u :: 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 i :: 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 Nothing     _    _ _) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
renewLoggerSet (LoggerSet (Just file :: FilePath
file) fref :: IORef FD
fref _ _) = 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 -> (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 mfile :: Maybe FilePath
mfile fdref :: IORef FD
fdref arr :: Array BufSize Logger
arr _) = do
    let (l :: BufSize
l,u :: 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 i :: 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 i :: BufSize
i = do
        let (Logger _ mbuf :: MVar Buffer
mbuf _) = 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 typ :: LogType' v
typ = case LogType' v
typ of
    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 bsize :: 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 bsize :: 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 fp :: FilePath
fp bsize :: 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 fspec :: FileLogSpec
fspec bsize :: BufSize
bsize            -> FileLogSpec -> BufSize -> IO (LogStr -> IO (), IO ())
rotateLoggerInit FileLogSpec
fspec BufSize
bsize
    LogFileTimedRotate fspec :: TimedFileLogSpec
fspec bsize :: BufSize
bsize -> TimedFileLogSpec -> BufSize -> IO (LogStr -> IO (), IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec BufSize
bsize
    LogCallback cb :: v -> IO ()
cb flush :: IO ()
flush           -> (v -> IO (), IO ()) -> IO (v -> IO (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (\str :: 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 lgrset :: 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 lgrset :: 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 fspec :: FileLogSpec
fspec bsize :: 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 (0 :: Int)
        MVar ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
        let logger :: LogStr -> IO ()
logger str :: 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
<= 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 fspec :: TimedFileLogSpec
fspec bsize :: 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 str :: 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 typ :: LogType
typ log' :: (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 tgetter :: IO FormattedTime
tgetter typ :: LogType
typ = case LogType
typ of
    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 bsize :: 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 bsize :: 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 fp :: FilePath
fp bsize :: 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 fspec :: FileLogSpec
fspec bsize :: BufSize
bsize            -> FileLogSpec -> BufSize -> IO (TimedFastLogger, IO ())
rotateLoggerInit FileLogSpec
fspec BufSize
bsize
    LogFileTimedRotate fspec :: TimedFileLogSpec
fspec bsize :: BufSize
bsize -> TimedFileLogSpec -> BufSize -> IO (TimedFastLogger, IO ())
timedRotateLoggerInit TimedFileLogSpec
fspec BufSize
bsize
    LogCallback cb :: LogStr -> IO ()
cb flush :: IO ()
flush           -> (TimedFastLogger, IO ()) -> IO (TimedFastLogger, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (\f :: 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 lgrset :: LoggerSet
lgrset = (TimedFastLogger, IO ()) -> IO (TimedFastLogger, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( \f :: 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 lgrset :: LoggerSet
lgrset = (TimedFastLogger, IO ()) -> IO (TimedFastLogger, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (\f :: 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 fspec :: FileLogSpec
fspec bsize :: 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 (0 :: Int)
        MVar ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
        let logger :: TimedFastLogger
logger f :: 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
<= 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 fspec :: TimedFileLogSpec
fspec bsize :: 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 f :: 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 tgetter :: IO FormattedTime
tgetter typ :: LogType
typ log' :: 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 ref :: IORef BufSize
ref = IORef BufSize -> (BufSize -> (BufSize, BufSize)) -> IO BufSize
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BufSize
ref (\x :: BufSize
x -> (BufSize
x BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
- 1, BufSize
x BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
- 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 cmp :: FormattedTime -> FormattedTime -> Bool
cmp ref :: IORef FormattedTime
ref newTime :: FormattedTime
newTime = IORef FormattedTime
-> (FormattedTime -> (FormattedTime, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef FormattedTime
ref (\x :: 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 lgrset :: LoggerSet
lgrset spec :: FileLogSpec
spec ref :: IORef BufSize
ref mvar :: 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 Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    unlock _       = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
    rotateFiles :: Maybe () -> IO ()
rotateFiles Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    rotateFiles _       = 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.
            Nothing -> IORef BufSize -> BufSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BufSize
ref 1000000
            Just siz :: 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 _) -> 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 x :: Integer
x = Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` 200)


tryTimedRotate :: TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO ()
tryTimedRotate :: TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO ()
tryTimedRotate spec :: TimedFileLogSpec
spec now :: FormattedTime
now mvar :: 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 Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    unlock (Just (LoggerSet current_path :: Maybe FilePath
current_path a :: IORef FD
a b :: Array BufSize Logger
b c :: 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
          Nothing   -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just path :: FilePath
path -> TimedFileLogSpec -> FilePath -> IO ()
timed_post_process TimedFileLogSpec
spec FilePath
path
    rotateFiles :: Maybe LoggerSet -> IO ()
rotateFiles Nothing  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    rotateFiles (Just (LoggerSet _ a :: IORef FD
a b :: Array BufSize Logger
b c :: 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