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
|
{-# LANGUAGE BangPatterns, CPP #-}
module System.Log.FastLogger.Logger (
Logger(..)
, newLogger
, pushLog
, flushLog
) where
import Control.Concurrent (MVar, newMVar, withMVar)
import Control.Monad (when)
import Foreign.Ptr (plusPtr)
import GHC.IO.FD (FD, writeRawBufferPtr)
import System.Log.FastLogger.IO
import System.Log.FastLogger.LogStr
import System.Log.FastLogger.IORef
----------------------------------------------------------------
data Logger = Logger (MVar Buffer) !BufSize (IORef LogStr)
----------------------------------------------------------------
newLogger :: BufSize -> IO Logger
newLogger size = do
buf <- getBuffer size
mbuf <- newMVar buf
lref <- newIORef mempty
return $ Logger mbuf size lref
----------------------------------------------------------------
pushLog :: FD -> Logger -> LogStr -> IO ()
pushLog fd logger@(Logger mbuf size ref) nlogmsg@(LogStr nlen nbuilder)
| nlen > size = do
flushLog fd logger
withMVar mbuf $ \buf -> toBufIOWith buf size (write fd) nbuilder
| otherwise = do
mmsg <- atomicModifyIORef' ref checkBuf
case mmsg of
Nothing -> return ()
Just msg -> withMVar mbuf $ \buf -> writeLogStr fd buf size msg
where
checkBuf ologmsg@(LogStr olen _)
| size < olen + nlen = (nlogmsg, Just ologmsg)
| otherwise = (ologmsg <> nlogmsg, Nothing)
----------------------------------------------------------------
flushLog :: FD -> Logger -> IO ()
flushLog fd (Logger mbuf size lref) = do
logmsg <- atomicModifyIORef' lref (\old -> (mempty, old))
-- If a special buffer is prepared for flusher, this MVar could
-- be removed. But such a code does not contribute logging speed
-- according to experiment. And even with the special buffer,
-- there is no grantee that this function is exclusively called
-- for a buffer. So, we use MVar here.
-- This is safe and speed penalty can be ignored.
withMVar mbuf $ \buf -> writeLogStr fd buf size logmsg
----------------------------------------------------------------
-- | Writting 'LogStr' using a buffer in blocking mode.
-- The size of 'LogStr' must be smaller or equal to
-- the size of buffer.
writeLogStr :: FD
-> Buffer
-> BufSize
-> LogStr
-> IO ()
writeLogStr fd buf size (LogStr len builder)
| size < len = error "writeLogStr"
| otherwise = toBufIOWith buf size (write fd) builder
write :: FD -> Buffer -> Int -> IO ()
write fd buf len' = loop buf (fromIntegral len')
where
loop bf !len = do
written <- writeRawBufferPtr "write" fd bf 0 (fromIntegral len)
when (written < len) $
loop (bf `plusPtr` fromIntegral written) (len - written)
|
