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