{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
module System.Log.FastLogger (
LoggerSet
, newFileLoggerSet
, newStdoutLoggerSet
, newStderrLoggerSet
, newLoggerSet
, BufSize
, defaultBufSize
, renewLoggerSet
, rmLoggerSet
, LogStr
, ToLogStr(..)
, fromLogStr
, logStrLength
, pushLogStr
, pushLogStrLn
, flushLogStr
, FastLogger
, TimedFastLogger
, LogType'(..), LogType
, newFastLogger
, withFastLogger
, newTimedFastLogger
, withTimedFastLogger
, module System.Log.FastLogger.Date
, module System.Log.FastLogger.File
, 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
data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD) (Array Int Logger) (IO ())
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)
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
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" #-}
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)
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
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
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
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")
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)
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
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
type FastLogger = LogStr -> IO ()
type TimedFastLogger = (FormattedTime -> LogStr) -> IO ()
type LogType = LogType' LogStr
data LogType' a where
LogNone :: LogType' LogStr
LogStdout :: BufSize -> LogType' LogStr
LogStderr :: BufSize -> LogType' LogStr
LogFileNoRotate :: FilePath -> BufSize -> LogType' LogStr
LogFile :: FileLogSpec -> BufSize -> LogType' LogStr
LogFileTimedRotate :: TimedFileLogSpec -> BufSize -> LogType' LogStr
LogCallback :: (v -> IO ()) -> IO () -> LogType' v
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)
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)
newTimedFastLogger ::
IO FormattedTime
-> 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)
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 :: (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
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
$
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
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