{-# LANGUAGE RecordWildCards #-}
module System.Log.FastLogger.SingleLogger (
SingleLogger
, newSingleLogger
) where
import Control.Concurrent (forkIO, newEmptyMVar, MVar, takeMVar, putMVar)
import Control.Concurrent.STM
import System.Log.FastLogger.FileIO
import System.Log.FastLogger.IO
import System.Log.FastLogger.Imports
import System.Log.FastLogger.LogStr
import System.Log.FastLogger.Write
data SingleLogger = SingleLogger {
SingleLogger -> IORef (LogStr, [LogStr])
slgrRef :: IORef (LogStr
,[LogStr])
, SingleLogger -> IO ()
slgrKill :: IO ()
, SingleLogger -> IO ()
slgrWakeup :: IO ()
, SingleLogger -> Buffer
slgrBuffer :: Buffer
, SingleLogger -> BufSize
slgrBufSize :: BufSize
, SingleLogger -> IORef FD
slgrFdRef :: IORef FD
}
instance Loggers SingleLogger where
stopLoggers :: SingleLogger -> IO ()
stopLoggers = SingleLogger -> IO ()
System.Log.FastLogger.SingleLogger.stopLoggers
pushLog :: SingleLogger -> LogStr -> IO ()
pushLog = SingleLogger -> LogStr -> IO ()
System.Log.FastLogger.SingleLogger.pushLog
flushAllLog :: SingleLogger -> IO ()
flushAllLog = SingleLogger -> IO ()
System.Log.FastLogger.SingleLogger.flushAllLog
writer :: BufSize -> Buffer -> IORef FD -> TVar Int -> IORef (LogStr, [LogStr]) -> MVar () -> IO ()
writer :: BufSize
-> Buffer
-> IORef FD
-> TVar BufSize
-> IORef (LogStr, [LogStr])
-> MVar ()
-> IO ()
writer BufSize
bufsize Buffer
buf IORef FD
fdref TVar BufSize
tvar IORef (LogStr, [LogStr])
ref MVar ()
mvar = BufSize -> IO ()
loop (BufSize
0 :: Int)
where
loop :: BufSize -> IO ()
loop BufSize
cnt = do
BufSize
cnt' <- STM BufSize -> IO BufSize
forall a. STM a -> IO a
atomically (STM BufSize -> IO BufSize) -> STM BufSize -> IO BufSize
forall a b. (a -> b) -> a -> b
$ do
BufSize
n <- TVar BufSize -> STM BufSize
forall a. TVar a -> STM a
readTVar TVar BufSize
tvar
Bool -> STM ()
check (BufSize
n BufSize -> BufSize -> Bool
forall a. Eq a => a -> a -> Bool
/= BufSize
cnt)
BufSize -> STM BufSize
forall (m :: * -> *) a. Monad m => a -> m a
return BufSize
n
[LogStr]
msgs <- [LogStr] -> [LogStr]
forall a. [a] -> [a]
reverse ([LogStr] -> [LogStr]) -> IO [LogStr] -> IO [LogStr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (LogStr, [LogStr])
-> ((LogStr, [LogStr]) -> ((LogStr, [LogStr]), [LogStr]))
-> IO [LogStr]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LogStr, [LogStr])
ref (\(LogStr
msg,[LogStr]
q) -> ((LogStr
msg,[]),[LogStr]
q))
Bool
cont <- [LogStr] -> IO Bool
go [LogStr]
msgs
if Bool
cont then
BufSize -> IO ()
loop BufSize
cnt'
else
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
go :: [LogStr] -> IO Bool
go [] = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
go (msg :: LogStr
msg@(LogStr BufSize
len Builder
_):[LogStr]
msgs)
| BufSize
len BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufSize
0 = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| BufSize
len BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
<= BufSize
bufsize = Buffer -> IORef FD -> LogStr -> IO ()
writeLogStr Buffer
buf IORef FD
fdref LogStr
msg IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [LogStr] -> IO Bool
go [LogStr]
msgs
| Bool
otherwise = IORef FD -> LogStr -> IO ()
writeBigLogStr IORef FD
fdref LogStr
msg IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [LogStr] -> IO Bool
go [LogStr]
msgs
newSingleLogger :: BufSize -> IORef FD -> IO SingleLogger
newSingleLogger :: BufSize -> IORef FD -> IO SingleLogger
newSingleLogger BufSize
bufsize IORef FD
fdref = do
TVar BufSize
tvar <- BufSize -> IO (TVar BufSize)
forall a. a -> IO (TVar a)
newTVarIO BufSize
0
IORef (LogStr, [LogStr])
ref <- (LogStr, [LogStr]) -> IO (IORef (LogStr, [LogStr]))
forall a. a -> IO (IORef a)
newIORef (LogStr
forall a. Monoid a => a
mempty,[])
MVar ()
mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
Buffer
buf <- BufSize -> IO Buffer
getBuffer BufSize
bufsize
ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ BufSize
-> Buffer
-> IORef FD
-> TVar BufSize
-> IORef (LogStr, [LogStr])
-> MVar ()
-> IO ()
writer BufSize
bufsize Buffer
buf IORef FD
fdref TVar BufSize
tvar IORef (LogStr, [LogStr])
ref MVar ()
mvar
let wakeup :: IO ()
wakeup = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar BufSize -> (BufSize -> BufSize) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar BufSize
tvar (BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
+ BufSize
1)
kill :: IO ()
kill = do
let fin :: LogStr
fin = BufSize -> Builder -> LogStr
LogStr (-BufSize
1) Builder
forall a. Monoid a => a
mempty
IORef (LogStr, [LogStr])
-> ((LogStr, [LogStr]) -> ((LogStr, [LogStr]), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LogStr, [LogStr])
ref (\(LogStr
old,[LogStr]
q) -> ((LogStr
forall a. Monoid a => a
mempty,LogStr
finLogStr -> [LogStr] -> [LogStr]
forall a. a -> [a] -> [a]
:LogStr
oldLogStr -> [LogStr] -> [LogStr]
forall a. a -> [a] -> [a]
:[LogStr]
q),()))
IO ()
wakeup
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar
SingleLogger -> IO SingleLogger
forall (m :: * -> *) a. Monad m => a -> m a
return (SingleLogger -> IO SingleLogger)
-> SingleLogger -> IO SingleLogger
forall a b. (a -> b) -> a -> b
$ SingleLogger :: IORef (LogStr, [LogStr])
-> IO () -> IO () -> Buffer -> BufSize -> IORef FD -> SingleLogger
SingleLogger {
slgrRef :: IORef (LogStr, [LogStr])
slgrRef = IORef (LogStr, [LogStr])
ref
, slgrKill :: IO ()
slgrKill = IO ()
kill
, slgrWakeup :: IO ()
slgrWakeup = IO ()
wakeup
, slgrBuffer :: Buffer
slgrBuffer = Buffer
buf
, slgrBufSize :: BufSize
slgrBufSize = BufSize
bufsize
, slgrFdRef :: IORef FD
slgrFdRef = IORef FD
fdref
}
pushLog :: SingleLogger -> LogStr -> IO ()
pushLog :: SingleLogger -> LogStr -> IO ()
pushLog SingleLogger{BufSize
IO ()
Buffer
IORef (LogStr, [LogStr])
IORef FD
slgrFdRef :: IORef FD
slgrBufSize :: BufSize
slgrBuffer :: Buffer
slgrWakeup :: IO ()
slgrKill :: IO ()
slgrRef :: IORef (LogStr, [LogStr])
slgrFdRef :: SingleLogger -> IORef FD
slgrBufSize :: SingleLogger -> BufSize
slgrBuffer :: SingleLogger -> Buffer
slgrWakeup :: SingleLogger -> IO ()
slgrKill :: SingleLogger -> IO ()
slgrRef :: SingleLogger -> IORef (LogStr, [LogStr])
..} nlogmsg :: LogStr
nlogmsg@(LogStr BufSize
nlen Builder
_)
| BufSize
nlen BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
> BufSize
slgrBufSize = do
IORef (LogStr, [LogStr])
-> ((LogStr, [LogStr]) -> ((LogStr, [LogStr]), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LogStr, [LogStr])
slgrRef (\(LogStr
old,[LogStr]
q) -> ((LogStr
forall a. Monoid a => a
mempty,LogStr
nlogmsgLogStr -> [LogStr] -> [LogStr]
forall a. a -> [a] -> [a]
:LogStr
oldLogStr -> [LogStr] -> [LogStr]
forall a. a -> [a] -> [a]
:[LogStr]
q),()))
IO ()
slgrWakeup
| Bool
otherwise = do
Bool
wake <- IORef (LogStr, [LogStr])
-> ((LogStr, [LogStr]) -> ((LogStr, [LogStr]), Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LogStr, [LogStr])
slgrRef (LogStr, [LogStr]) -> ((LogStr, [LogStr]), Bool)
checkBuf
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wake IO ()
slgrWakeup
where
checkBuf :: (LogStr, [LogStr]) -> ((LogStr, [LogStr]), Bool)
checkBuf (ologmsg :: LogStr
ologmsg@(LogStr BufSize
olen Builder
_),[LogStr]
q)
| BufSize
slgrBufSize BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufSize
olen BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
+ BufSize
nlen = ((LogStr
nlogmsg, LogStr
ologmsgLogStr -> [LogStr] -> [LogStr]
forall a. a -> [a] -> [a]
:[LogStr]
q), Bool
True)
| Bool
otherwise = ((LogStr
ologmsg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
nlogmsg, [LogStr]
q), Bool
False)
flushAllLog :: SingleLogger -> IO ()
flushAllLog :: SingleLogger -> IO ()
flushAllLog SingleLogger{BufSize
IO ()
Buffer
IORef (LogStr, [LogStr])
IORef FD
slgrFdRef :: IORef FD
slgrBufSize :: BufSize
slgrBuffer :: Buffer
slgrWakeup :: IO ()
slgrKill :: IO ()
slgrRef :: IORef (LogStr, [LogStr])
slgrFdRef :: SingleLogger -> IORef FD
slgrBufSize :: SingleLogger -> BufSize
slgrBuffer :: SingleLogger -> Buffer
slgrWakeup :: SingleLogger -> IO ()
slgrKill :: SingleLogger -> IO ()
slgrRef :: SingleLogger -> IORef (LogStr, [LogStr])
..} = do
IORef (LogStr, [LogStr])
-> ((LogStr, [LogStr]) -> ((LogStr, [LogStr]), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LogStr, [LogStr])
slgrRef (\(LogStr
old,[LogStr]
q) -> ((LogStr
forall a. Monoid a => a
mempty,LogStr
oldLogStr -> [LogStr] -> [LogStr]
forall a. a -> [a] -> [a]
:[LogStr]
q),()))
IO ()
slgrWakeup
stopLoggers :: SingleLogger -> IO ()
stopLoggers :: SingleLogger -> IO ()
stopLoggers SingleLogger{BufSize
IO ()
Buffer
IORef (LogStr, [LogStr])
IORef FD
slgrFdRef :: IORef FD
slgrBufSize :: BufSize
slgrBuffer :: Buffer
slgrWakeup :: IO ()
slgrKill :: IO ()
slgrRef :: IORef (LogStr, [LogStr])
slgrFdRef :: SingleLogger -> IORef FD
slgrBufSize :: SingleLogger -> BufSize
slgrBuffer :: SingleLogger -> Buffer
slgrWakeup :: SingleLogger -> IO ()
slgrKill :: SingleLogger -> IO ()
slgrRef :: SingleLogger -> IORef (LogStr, [LogStr])
..} = do
IO ()
slgrKill
Buffer -> IO ()
freeBuffer Buffer
slgrBuffer