1{-# LANGUAGE OverloadedStrings #-}
2
3module System.Log.FastLogger.LoggerSet (
4  -- * Creating a logger set
5    LoggerSet
6  , newFileLoggerSet
7  , newStdoutLoggerSet
8  , newStderrLoggerSet
9  , newLoggerSet
10  -- * Renewing and removing a logger set
11  , renewLoggerSet
12  , rmLoggerSet
13  -- * Writing a log message
14  , pushLogStr
15  , pushLogStrLn
16  -- * Flushing buffered log messages
17  , flushLogStr
18  -- * Misc
19  , replaceLoggerSet
20  ) where
21
22import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceAction)
23import Control.Concurrent (getNumCapabilities, myThreadId, threadCapability, takeMVar)
24import Data.Array (Array, listArray, (!), bounds)
25
26import System.Log.FastLogger.FileIO
27import System.Log.FastLogger.IO
28import System.Log.FastLogger.Imports
29import System.Log.FastLogger.LogStr
30import System.Log.FastLogger.Logger
31
32----------------------------------------------------------------
33
34-- | A set of loggers.
35--   The number of loggers is the capabilities of GHC RTS.
36--   You can specify it with \"+RTS -N\<x\>\".
37--   A buffer is prepared for each capability.
38data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD) (Array Int Logger) (IO ())
39
40-- | Creating a new 'LoggerSet' using a file.
41newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet
42newFileLoggerSet size file = openFileFD file >>= newFDLoggerSet size (Just file)
43
44-- | Creating a new 'LoggerSet' using stdout.
45newStdoutLoggerSet :: BufSize -> IO LoggerSet
46newStdoutLoggerSet size = getStdoutFD >>= newFDLoggerSet size Nothing
47
48-- | Creating a new 'LoggerSet' using stderr.
49newStderrLoggerSet :: BufSize -> IO LoggerSet
50newStderrLoggerSet size = getStderrFD >>= newFDLoggerSet size Nothing
51
52{-# DEPRECATED newLoggerSet "Use newFileLoggerSet etc instead" #-}
53-- | Creating a new 'LoggerSet'.
54--   If 'Nothing' is specified to the second argument,
55--   stdout is used.
56--   Please note that the minimum 'BufSize' is 1.
57newLoggerSet :: BufSize -> Maybe FilePath -> IO LoggerSet
58newLoggerSet size = maybe (newStdoutLoggerSet size) (newFileLoggerSet size)
59
60-- | Creating a new 'LoggerSet' using a FD.
61newFDLoggerSet :: BufSize -> Maybe FilePath -> FD -> IO LoggerSet
62newFDLoggerSet size mfile fd = do
63    n <- getNumCapabilities
64    loggers <- replicateM n $ newLogger (max 1 size)
65    let arr = listArray (0,n-1) loggers
66    fref <- newIORef fd
67    flush <- mkDebounce defaultDebounceSettings
68        { debounceAction = flushLogStrRaw fref arr
69        }
70    return $ LoggerSet mfile fref arr flush
71
72-- | Writing a log message to the corresponding buffer.
73--   If the buffer becomes full, the log messages in the buffer
74--   are written to its corresponding file, stdout, or stderr.
75pushLogStr :: LoggerSet -> LogStr -> IO ()
76pushLogStr (LoggerSet _ fdref arr flush) logmsg = do
77    (i, _) <- myThreadId >>= threadCapability
78    -- The number of capability could be dynamically changed.
79    -- So, let's check the upper boundary of the array.
80    let u = snd $ bounds arr
81        lim = u + 1
82        j | i < lim   = i
83          | otherwise = i `mod` lim
84    let logger = arr ! j
85    pushLog fdref logger logmsg
86    flush
87
88-- | Same as 'pushLogStr' but also appends a newline.
89pushLogStrLn :: LoggerSet -> LogStr -> IO ()
90pushLogStrLn loggerSet logStr = pushLogStr loggerSet (logStr <> "\n")
91
92-- | Flushing log messages in buffers.
93--   This function must be called explicitly when the program is
94--   being terminated.
95--
96--   Note: Since version 2.1.6, this function does not need to be
97--   explicitly called, as every push includes an auto-debounced flush
98--   courtesy of the auto-update package. Since version 2.2.2, this
99--   function can be used to force flushing outside of the debounced
100--   flush calls.
101flushLogStr :: LoggerSet -> IO ()
102flushLogStr (LoggerSet _ fref arr _) = flushLogStrRaw fref arr
103
104flushLogStrRaw :: IORef FD -> Array Int Logger -> IO ()
105flushLogStrRaw fdref arr = do
106    let (l,u) = bounds arr
107    mapM_ flushIt [l .. u]
108  where
109    flushIt i = flushLog fdref (arr ! i)
110
111-- | Renewing the internal file information in 'LoggerSet'.
112--   This does nothing for stdout and stderr.
113renewLoggerSet :: LoggerSet -> IO ()
114renewLoggerSet (LoggerSet Nothing     _    _ _) = return ()
115renewLoggerSet (LoggerSet (Just file) fref _ _) = do
116    newfd <- openFileFD file
117    oldfd <- atomicModifyIORef' fref (\fd -> (newfd, fd))
118    closeFD oldfd
119
120-- | Flushing the buffers, closing the internal file information
121--   and freeing the buffers.
122rmLoggerSet :: LoggerSet -> IO ()
123rmLoggerSet (LoggerSet mfile fdref arr _) = do
124    let (l,u) = bounds arr
125    let nums = [l .. u]
126    mapM_ flushIt nums
127    mapM_ freeIt nums
128    fd <- readIORef fdref
129    when (isJust mfile) $ closeFD fd
130  where
131    flushIt i = flushLog fdref (arr ! i)
132    freeIt i = do
133        let (Logger _ mbuf _) = arr ! i
134        takeMVar mbuf >>= freeBuffer
135
136-- | Replacing the file path in 'LoggerSet' and returning a new
137--   'LoggerSet' and the old file path.
138replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
139replaceLoggerSet (LoggerSet current_path a b c) new_file_path =
140    (LoggerSet (Just new_file_path) a b c, current_path)
141