{-# LANGUAGE OverloadedStrings #-}
module System.Log.FastLogger.LoggerSet (
LoggerSet
, newFileLoggerSet
, newFileLoggerSetN
, newStdoutLoggerSet
, newStdoutLoggerSetN
, newStderrLoggerSet
, newStderrLoggerSetN
, newLoggerSet
, newFDLoggerSet
, renewLoggerSet
, rmLoggerSet
, pushLogStr
, pushLogStrLn
, flushLogStr
, replaceLoggerSet
) where
import Control.Concurrent (MVar, getNumCapabilities, myThreadId, threadCapability, takeMVar, newMVar)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceAction)
import Data.Array (Array, listArray, (!), bounds)
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
data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD)
BufSize (MVar Buffer)
(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 BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)
newFileLoggerSetN :: BufSize -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN :: BufSize -> Maybe BufSize -> FilePath -> IO LoggerSet
newFileLoggerSetN BufSize
size Maybe BufSize
mn 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 BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
mn (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 BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing
newStdoutLoggerSetN :: BufSize -> Maybe Int -> IO LoggerSet
newStdoutLoggerSetN :: BufSize -> Maybe BufSize -> IO LoggerSet
newStdoutLoggerSetN BufSize
size Maybe BufSize
mn = 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 BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
mn 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 BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing
newStderrLoggerSetN :: BufSize -> Maybe Int -> IO LoggerSet
newStderrLoggerSetN :: BufSize -> Maybe BufSize -> IO LoggerSet
newStderrLoggerSetN BufSize
size Maybe BufSize
mn = 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 BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
mn Maybe FilePath
forall a. Maybe a
Nothing
{-# DEPRECATED newLoggerSet "Use newFileLoggerSet etc instead" #-}
newLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> IO LoggerSet
newLoggerSet :: BufSize -> Maybe BufSize -> Maybe FilePath -> IO LoggerSet
newLoggerSet BufSize
size Maybe BufSize
mn = 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 -> Maybe BufSize -> FilePath -> IO LoggerSet
newFileLoggerSetN BufSize
size Maybe BufSize
mn)
newFDLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet :: BufSize -> Maybe BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
mn Maybe FilePath
mfile FD
fd = do
BufSize
n <- case Maybe BufSize
mn of
Just BufSize
n' -> BufSize -> IO BufSize
forall (m :: * -> *) a. Monad m => a -> m a
return BufSize
n'
Maybe BufSize
Nothing -> 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
newLogger
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
let bufsiz :: BufSize
bufsiz = BufSize -> BufSize -> BufSize
forall a. Ord a => a -> a -> a
max BufSize
1 BufSize
size
MVar Buffer
mbuf <- BufSize -> IO Buffer
getBuffer BufSize
bufsiz IO Buffer -> (Buffer -> IO (MVar Buffer)) -> IO (MVar Buffer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Buffer -> IO (MVar Buffer)
forall a. a -> IO (MVar a)
newMVar
IO ()
flush <- DebounceSettings -> IO (IO ())
mkDebounce DebounceSettings
defaultDebounceSettings
{ debounceAction :: IO ()
debounceAction = IORef FD -> BufSize -> MVar Buffer -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fref BufSize
bufsiz MVar Buffer
mbuf 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
-> BufSize
-> MVar Buffer
-> Array BufSize Logger
-> IO ()
-> LoggerSet
LoggerSet Maybe FilePath
mfile IORef FD
fref BufSize
bufsiz MVar Buffer
mbuf Array BufSize Logger
arr IO ()
flush
pushLogStr :: LoggerSet -> LogStr -> IO ()
pushLogStr :: LoggerSet -> LogStr -> IO ()
pushLogStr (LoggerSet Maybe FilePath
_ IORef FD
fdref BufSize
size MVar Buffer
mbuf 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 -> BufSize -> MVar Buffer -> Logger -> LogStr -> IO ()
pushLog IORef FD
fdref BufSize
size MVar Buffer
mbuf 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 BufSize
size MVar Buffer
mbuf Array BufSize Logger
arr IO ()
_) = IORef FD -> BufSize -> MVar Buffer -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fref BufSize
size MVar Buffer
mbuf Array BufSize Logger
arr
flushLogStrRaw :: IORef FD -> BufSize -> MVar Buffer -> Array Int Logger -> IO ()
flushLogStrRaw :: IORef FD -> BufSize -> MVar Buffer -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fdref BufSize
size MVar Buffer
mbuf 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 -> BufSize -> MVar Buffer -> Logger -> IO ()
flushLog IORef FD
fdref BufSize
size MVar Buffer
mbuf (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
_ BufSize
_ MVar Buffer
_ Array BufSize Logger
_ IO ()
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
renewLoggerSet (LoggerSet (Just FilePath
file) IORef FD
fref BufSize
_ MVar Buffer
_ 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 BufSize
size MVar Buffer
mbuf Array BufSize Logger
arr IO ()
_) = do
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 (FD -> Bool
isFDValid FD
fd) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
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
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
IORef FD -> FD -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FD
fdref FD
invalidFD
where
flushIt :: BufSize -> IO ()
flushIt BufSize
i = IORef FD -> BufSize -> MVar Buffer -> Logger -> IO ()
flushLog IORef FD
fdref BufSize
size MVar Buffer
mbuf(Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i)
replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
replaceLoggerSet (LoggerSet Maybe FilePath
current_path IORef FD
a BufSize
b MVar Buffer
c Array BufSize Logger
d IO ()
e) FilePath
new_file_path =
(Maybe FilePath
-> IORef FD
-> BufSize
-> MVar Buffer
-> Array BufSize Logger
-> IO ()
-> LoggerSet
LoggerSet (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
new_file_path) IORef FD
a BufSize
b MVar Buffer
c Array BufSize Logger
d IO ()
e, Maybe FilePath
current_path)