1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
{-# LANGUAGE RecordWildCards #-}
module System.Log.FastLogger.SingleLogger (
SingleLogger,
newSingleLogger,
) where
import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar)
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 Ent = F (MVar ()) Bool | L LogStr
type Q = [Ent] -- writer queue
-- | A non-scale but time-ordered logger.
data SingleLogger = SingleLogger
{ slgrRef :: IORef (LogStr, Q)
, slgrFlush :: Bool -> IO () -- teminate if False
, slgrWakeup :: IO ()
, slgrBuffer :: Buffer
, slgrBufSize :: BufSize
, slgrFdRef :: IORef FD
}
instance Loggers SingleLogger where
stopLoggers = System.Log.FastLogger.SingleLogger.stopLoggers
pushLog = System.Log.FastLogger.SingleLogger.pushLog
flushAllLog = System.Log.FastLogger.SingleLogger.flushAllLog
----------------------------------------------------------------
writer
:: BufSize
-> Buffer
-> IORef FD
-> TVar Int
-> IORef (LogStr, Q)
-> IO ()
writer bufsize buf fdref tvar ref = loop (0 :: Int)
where
loop cnt = do
cnt' <- atomically $ do
n <- readTVar tvar
check (n /= cnt)
return n
msgs <- reverse <$> atomicModifyIORef' ref (\(msg, q) -> ((msg, []), q))
cont <- go msgs
when cont $ loop cnt'
go [] = return True
go (F mvar cont : msgs) = do
putMVar mvar ()
if cont then go msgs else return False
go (L msg@(LogStr len _) : msgs)
| len <= bufsize = writeLogStr buf fdref msg >> go msgs
| otherwise = writeBigLogStr fdref msg >> go msgs
----------------------------------------------------------------
-- | Creating `SingleLogger`.
newSingleLogger :: BufSize -> IORef FD -> IO SingleLogger
newSingleLogger bufsize fdref = do
tvar <- newTVarIO 0
ref <- newIORef (mempty, [])
buf <- getBuffer bufsize
_ <- forkIO $ writer bufsize buf fdref tvar ref
let wakeup = atomically $ modifyTVar' tvar (+ 1)
flush cont = do
mvar <- newEmptyMVar
let fin = F mvar cont
atomicModifyIORef' ref (\(old, q) -> ((mempty, fin : L old : q), ()))
wakeup
takeMVar mvar
return $
SingleLogger
{ slgrRef = ref
, slgrFlush = flush
, slgrWakeup = wakeup
, slgrBuffer = buf
, slgrBufSize = bufsize
, slgrFdRef = fdref
}
----------------------------------------------------------------
pushLog :: SingleLogger -> LogStr -> IO ()
pushLog SingleLogger{..} nlogmsg@(LogStr nlen _)
| nlen > slgrBufSize = do
atomicModifyIORef' slgrRef (\(old, q) -> ((mempty, L nlogmsg : L old : q), ()))
slgrWakeup
| otherwise = do
wake <- atomicModifyIORef' slgrRef checkBuf
when wake slgrWakeup
where
checkBuf (ologmsg@(LogStr olen _), q)
| slgrBufSize < olen + nlen = ((nlogmsg, L ologmsg : q), True)
| otherwise = ((ologmsg <> nlogmsg, q), False)
flushAllLog :: SingleLogger -> IO ()
flushAllLog SingleLogger{..} = do
atomicModifyIORef' slgrRef (\(old, q) -> ((mempty, L old : q), ()))
slgrFlush True
stopLoggers :: SingleLogger -> IO ()
stopLoggers SingleLogger{..} = do
slgrFlush False
freeBuffer slgrBuffer
|
