{-# 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 :: Int -> FilePath -> IO LoggerSet
newFileLoggerSet Int
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
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)
newFileLoggerSetN :: BufSize -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN :: Int -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN Int
size Maybe Int
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
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
mn (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)
newStdoutLoggerSet :: BufSize -> IO LoggerSet
newStdoutLoggerSet :: Int -> IO LoggerSet
newStdoutLoggerSet Int
size = IO FD
getStdoutFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing
newStdoutLoggerSetN :: BufSize -> Maybe Int -> IO LoggerSet
newStdoutLoggerSetN :: Int -> Maybe Int -> IO LoggerSet
newStdoutLoggerSetN Int
size Maybe Int
mn = IO FD
getStdoutFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
mn Maybe FilePath
forall a. Maybe a
Nothing
newStderrLoggerSet :: BufSize -> IO LoggerSet
newStderrLoggerSet :: Int -> IO LoggerSet
newStderrLoggerSet Int
size = IO FD
getStderrFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing
newStderrLoggerSetN :: BufSize -> Maybe Int -> IO LoggerSet
newStderrLoggerSetN :: Int -> Maybe Int -> IO LoggerSet
newStderrLoggerSetN Int
size Maybe Int
mn = IO FD
getStderrFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
mn Maybe FilePath
forall a. Maybe a
Nothing
{-# DEPRECATED newLoggerSet "Use newFileLoggerSet etc instead" #-}
newLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> IO LoggerSet
newLoggerSet :: Int -> Maybe Int -> Maybe FilePath -> IO LoggerSet
newLoggerSet Int
size Maybe Int
mn = IO LoggerSet
-> (FilePath -> IO LoggerSet) -> Maybe FilePath -> IO LoggerSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> IO LoggerSet
newStdoutLoggerSet Int
size) (Int -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN Int
size Maybe Int
mn)
newFDLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet :: Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
mn Maybe FilePath
mfile FD
fd = do
Int
n <- case Maybe Int
mn of
Just Int
n' -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'
Maybe Int
Nothing -> IO Int
getNumCapabilities
[Logger]
loggers <- Int -> IO Logger -> IO [Logger]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n IO Logger
newLogger
let arr :: Array Int Logger
arr = (Int, Int) -> [Logger] -> Array Int Logger
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Logger]
loggers
IORef FD
fref <- FD -> IO (IORef FD)
forall a. a -> IO (IORef a)
newIORef FD
fd
let bufsiz :: Int
bufsiz = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
size
MVar Buffer
mbuf <- Int -> IO Buffer
getBuffer Int
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 -> Int -> MVar Buffer -> Array Int Logger -> IO ()
flushLogStrRaw IORef FD
fref Int
bufsiz MVar Buffer
mbuf Array Int 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
-> Int
-> MVar Buffer
-> Array Int Logger
-> IO ()
-> LoggerSet
LoggerSet Maybe FilePath
mfile IORef FD
fref Int
bufsiz MVar Buffer
mbuf Array Int Logger
arr IO ()
flush
pushLogStr :: LoggerSet -> LogStr -> IO ()
pushLogStr :: LoggerSet -> LogStr -> IO ()
pushLogStr (LoggerSet Maybe FilePath
_ IORef FD
fdref Int
size MVar Buffer
mbuf Array Int Logger
arr IO ()
flush) LogStr
logmsg = do
(Int
i, Bool
_) <- IO ThreadId
myThreadId IO ThreadId -> (ThreadId -> IO (Int, Bool)) -> IO (Int, Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ThreadId -> IO (Int, Bool)
threadCapability
let u :: Int
u = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Array Int Logger -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int Logger
arr
lim :: Int
lim = Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
j :: Int
j | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lim = Int
i
| Bool
otherwise = Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
lim
let logger :: Logger
logger = Array Int Logger
arr Array Int Logger -> Int -> Logger
forall i e. Ix i => Array i e -> i -> e
! Int
j
IORef FD -> Int -> MVar Buffer -> Logger -> LogStr -> IO ()
pushLog IORef FD
fdref Int
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 Int
size MVar Buffer
mbuf Array Int Logger
arr IO ()
_) = IORef FD -> Int -> MVar Buffer -> Array Int Logger -> IO ()
flushLogStrRaw IORef FD
fref Int
size MVar Buffer
mbuf Array Int Logger
arr
flushLogStrRaw :: IORef FD -> BufSize -> MVar Buffer -> Array Int Logger -> IO ()
flushLogStrRaw :: IORef FD -> Int -> MVar Buffer -> Array Int Logger -> IO ()
flushLogStrRaw IORef FD
fdref Int
size MVar Buffer
mbuf Array Int Logger
arr = do
let (Int
l,Int
u) = Array Int Logger -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int Logger
arr
(Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
flushIt [Int
l .. Int
u]
where
flushIt :: Int -> IO ()
flushIt Int
i = IORef FD -> Int -> MVar Buffer -> Logger -> IO ()
flushLog IORef FD
fdref Int
size MVar Buffer
mbuf (Array Int Logger
arr Array Int Logger -> Int -> Logger
forall i e. Ix i => Array i e -> i -> e
! Int
i)
renewLoggerSet :: LoggerSet -> IO ()
renewLoggerSet :: LoggerSet -> IO ()
renewLoggerSet (LoggerSet Maybe FilePath
Nothing IORef FD
_ Int
_ MVar Buffer
_ Array Int Logger
_ IO ()
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
renewLoggerSet (LoggerSet (Just FilePath
file) IORef FD
fref Int
_ MVar Buffer
_ Array Int 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 Int
size MVar Buffer
mbuf Array Int 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 (Int
l,Int
u) = Array Int Logger -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int Logger
arr
let nums :: [Int]
nums = [Int
l .. Int
u]
(Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
flushIt [Int]
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 :: Int -> IO ()
flushIt Int
i = IORef FD -> Int -> MVar Buffer -> Logger -> IO ()
flushLog IORef FD
fdref Int
size MVar Buffer
mbuf(Array Int Logger
arr Array Int Logger -> Int -> Logger
forall i e. Ix i => Array i e -> i -> e
! Int
i)
replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
replaceLoggerSet (LoggerSet Maybe FilePath
current_path IORef FD
a Int
b MVar Buffer
c Array Int Logger
d IO ()
e) FilePath
new_file_path =
(Maybe FilePath
-> IORef FD
-> Int
-> MVar Buffer
-> Array Int Logger
-> IO ()
-> LoggerSet
LoggerSet (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
new_file_path) IORef FD
a Int
b MVar Buffer
c Array Int Logger
d IO ()
e, Maybe FilePath
current_path)