1{-# LANGUAGE CPP               #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE GADTs             #-}
4
5-- | This module provides a fast logging system which
6--   scales on multicore environments (i.e. +RTS -N\<x\>).
7--
8--   Note: This library does not guarantee correct ordering of log messages
9--   when program is run on more than one core thus users
10--   should rely more on message timestamps than on their order in the
11--   log.
12module System.Log.FastLogger (
13  -- * FastLogger
14    FastLogger
15  , LogType
16  , LogType'(..)
17  , newFastLogger
18  , newFastLogger1
19  , withFastLogger
20  -- * Timed FastLogger
21  , TimedFastLogger
22  , newTimedFastLogger
23  , withTimedFastLogger
24  -- * Log messages
25  , LogStr
26  , ToLogStr(..)
27  , fromLogStr
28  , logStrLength
29  -- * Buffer size
30  , BufSize
31  , defaultBufSize
32  -- * LoggerSet
33  , module System.Log.FastLogger.LoggerSet
34  -- * Date cache
35  , module System.Log.FastLogger.Date
36  -- * File rotation
37  , module System.Log.FastLogger.File
38  -- * Types
39  , module System.Log.FastLogger.Types
40  ) where
41
42import Control.Concurrent (MVar, newMVar, tryTakeMVar, putMVar)
43import Control.Exception (handle, SomeException(..), bracket)
44import System.EasyFile (getFileSize)
45
46import System.Log.FastLogger.Date
47import System.Log.FastLogger.File
48import System.Log.FastLogger.IO
49import System.Log.FastLogger.Imports
50import System.Log.FastLogger.LogStr
51import System.Log.FastLogger.LoggerSet
52import System.Log.FastLogger.Types
53
54----------------------------------------------------------------
55
56-- | 'FastLogger' simply log 'logStr'.
57type FastLogger = LogStr -> IO ()
58-- | 'TimedFastLogger' pass 'FormattedTime' to callback and simply log its result.
59-- this can be used to customize how to log timestamp.
60--
61-- Usually, one would write a wrapper on top of 'TimedFastLogger', for example:
62--
63-- > {-# LANGUAGE OverloadedStrings #-}
64-- >
65-- > log :: TimedFastLogger -> LogStr -> IO ()
66-- > log logger msg = logger (\time -> toLogStr (show time) <> " " <> msg <> "\n")
67type TimedFastLogger = (FormattedTime -> LogStr) -> IO ()
68
69type LogType = LogType' LogStr
70
71-- | Logger Type.
72data LogType' a where
73    LogNone :: LogType' LogStr    -- ^ No logging.
74    LogStdout :: BufSize -> LogType' LogStr
75                                  -- ^ Logging to stdout.
76                                  --   'BufSize' is a buffer size
77                                  --   for each capability.
78    LogStderr :: BufSize -> LogType' LogStr
79                                  -- ^ Logging to stderr.
80                                  --   'BufSize' is a buffer size
81                                  --   for each capability.
82    LogFileNoRotate :: FilePath -> BufSize -> LogType' LogStr
83                                  -- ^ Logging to a file.
84                                  --   'BufSize' is a buffer size
85                                  --   for each capability.
86    LogFile :: FileLogSpec -> BufSize -> LogType' LogStr
87                                  -- ^ Logging to a file.
88                                  --   'BufSize' is a buffer size
89                                  --   for each capability.
90                                  --   File rotation is done on-demand.
91    LogFileTimedRotate :: TimedFileLogSpec -> BufSize -> LogType' LogStr -- ^ Logging to a file.
92                                  --   'BufSize' is a buffer size
93                                  --   for each capability.
94                                  --   Rotation happens based on check specified
95                                  --   in 'TimedFileLogSpec'.
96    LogCallback :: (v -> IO ()) -> IO () -> LogType' v  -- ^ Logging with a log and flush action.
97                                                          -- run flush after log each message.
98
99-- | Initialize a 'FastLogger' without attaching timestamp
100-- a tuple of logger and clean up action are returned.
101-- This type signature should be read as:
102--
103-- > newFastLogger :: LogType -> IO (FastLogger, IO ())
104newFastLogger :: LogType' v -> IO (v -> IO (), IO ())
105newFastLogger typ = newFastLoggerCore Nothing typ
106
107newFastLogger1 :: LogType' v -> IO (v -> IO (), IO ())
108newFastLogger1 typ = newFastLoggerCore (Just 1) typ
109
110newFastLoggerCore :: Maybe Int -> LogType' v -> IO (v -> IO (), IO ())
111newFastLoggerCore mn typ = case typ of
112    LogNone                        -> return (const noOp, noOp)
113    LogStdout bsize                -> newStdoutLoggerSet bsize >>= stdLoggerInit
114    LogStderr bsize                -> newStderrLoggerSet bsize >>= stdLoggerInit
115    LogFileNoRotate fp bsize       -> newFileLoggerSetN bsize mn fp >>= fileLoggerInit
116    LogFile fspec bsize            -> rotateLoggerInit fspec bsize
117    LogFileTimedRotate fspec bsize -> timedRotateLoggerInit fspec bsize
118    LogCallback cb flush           -> return (\str -> cb str >> flush, noOp)
119  where
120    stdLoggerInit lgrset = return (pushLogStr lgrset, rmLoggerSet lgrset)
121    fileLoggerInit lgrset = return (pushLogStr lgrset, rmLoggerSet lgrset)
122    rotateLoggerInit fspec bsize = do
123        lgrset <- newFileLoggerSetN bsize mn $ log_file fspec
124        ref <- newIORef (0 :: Int)
125        mvar <- newMVar ()
126        let logger str = do
127                cnt <- decrease ref
128                pushLogStr lgrset str
129                when (cnt <= 0) $ tryRotate lgrset fspec ref mvar
130        return (logger, rmLoggerSet lgrset)
131    timedRotateLoggerInit fspec bsize = do
132        cache <- newTimeCache $ timed_timefmt fspec
133        now <- cache
134        lgrset <- newFileLoggerSetN bsize mn $ prefixTime now $ timed_log_file fspec
135        ref <- newIORef now
136        mvar <- newMVar lgrset
137        let logger str = do
138                ct <- cache
139                updated <- updateTime (timed_same_timeframe fspec) ref ct
140                when updated $ tryTimedRotate fspec ct mvar
141                pushLogStr lgrset str
142        return (logger, rmLoggerSet lgrset)
143
144-- | 'bracket' version of 'newFastLogger'
145withFastLogger :: LogType -> (FastLogger -> IO a) -> IO a
146withFastLogger typ log' = bracket (newFastLogger typ) snd (log' . fst)
147
148-- | Initialize a 'FastLogger' with timestamp attached to each message.
149-- a tuple of logger and clean up action are returned.
150newTimedFastLogger ::
151    IO FormattedTime    -- ^ How do we get 'FormattedTime'?
152                        -- "System.Log.FastLogger.Date" provide cached formatted time.
153    -> LogType -> IO (TimedFastLogger, IO ())
154newTimedFastLogger tgetter typ = case typ of
155    LogNone                        -> return (const noOp, noOp)
156    LogStdout bsize                -> newStdoutLoggerSet bsize >>= stdLoggerInit
157    LogStderr bsize                -> newStderrLoggerSet bsize >>= stdLoggerInit
158    LogFileNoRotate fp bsize       -> newFileLoggerSet bsize fp >>= fileLoggerInit
159    LogFile fspec bsize            -> rotateLoggerInit fspec bsize
160    LogFileTimedRotate fspec bsize -> timedRotateLoggerInit fspec bsize
161    LogCallback cb flush           -> return (\f -> tgetter >>= cb . f >> flush, noOp)
162  where
163    stdLoggerInit lgrset = return ( \f -> tgetter >>= pushLogStr lgrset . f, rmLoggerSet lgrset)
164    fileLoggerInit lgrset = return (\f -> tgetter >>= pushLogStr lgrset . f, rmLoggerSet lgrset)
165    rotateLoggerInit fspec bsize = do
166        lgrset <- newFileLoggerSet bsize $ log_file fspec
167        ref <- newIORef (0 :: Int)
168        mvar <- newMVar ()
169        let logger f = do
170                cnt <- decrease ref
171                t <- tgetter
172                pushLogStr lgrset (f t)
173                when (cnt <= 0) $ tryRotate lgrset fspec ref mvar
174        return (logger, rmLoggerSet lgrset)
175    timedRotateLoggerInit fspec bsize = do
176        cache <- newTimeCache $ timed_timefmt fspec
177        now <- cache
178        lgrset <- newFileLoggerSet bsize $ prefixTime now $ timed_log_file fspec
179        ref <- newIORef now
180        mvar <- newMVar lgrset
181        let logger f = do
182                ct <- cache
183                updated <- updateTime (timed_same_timeframe fspec) ref ct
184                when updated $ tryTimedRotate fspec ct mvar
185                t <- tgetter
186                pushLogStr lgrset (f t)
187        return (logger, rmLoggerSet lgrset)
188
189-- | 'bracket' version of 'newTimeFastLogger'
190withTimedFastLogger :: IO FormattedTime -> LogType -> (TimedFastLogger -> IO a) -> IO a
191withTimedFastLogger tgetter typ log' = bracket (newTimedFastLogger tgetter typ) snd (log' . fst)
192
193----------------------------------------------------------------
194
195noOp :: IO ()
196noOp = return ()
197
198decrease :: IORef Int -> IO Int
199decrease ref = atomicModifyIORef' ref (\x -> (x - 1, x - 1))
200
201-- updateTime returns whether the timeframe has changed
202updateTime :: (FormattedTime -> FormattedTime -> Bool) -> IORef FormattedTime -> FormattedTime -> IO Bool
203updateTime cmp ref newTime = atomicModifyIORef' ref (\x -> (newTime, not $ cmp x newTime))
204
205tryRotate :: LoggerSet -> FileLogSpec -> IORef Int -> MVar () -> IO ()
206tryRotate lgrset spec ref mvar = bracket lock unlock rotateFiles
207  where
208    lock           = tryTakeMVar mvar
209    unlock Nothing = return ()
210    unlock _       = putMVar mvar ()
211    rotateFiles Nothing = return ()
212    rotateFiles _       = do
213        msiz <- getSize
214        case msiz of
215            -- A file is not available.
216            -- So, let's set a big value to the counter so that
217            -- this function is not called frequently.
218            Nothing -> writeIORef ref 1000000
219            Just siz
220                | siz > limit -> do
221                    rotate spec
222                    renewLoggerSet lgrset
223                    writeIORef ref $ estimate limit
224                | otherwise ->
225                    writeIORef ref $ estimate (limit - siz)
226    file = log_file spec
227    limit = log_file_size spec
228    getSize = handle (\(SomeException _) -> return Nothing) $
229        -- The log file is locked by GHC.
230        -- We need to get its file size by the way not using locks.
231        Just . fromIntegral <$> getFileSize file
232    -- 200 is an ad-hoc value for the length of log line.
233    estimate x = fromInteger (x `div` 200)
234
235tryTimedRotate :: TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO ()
236tryTimedRotate spec now mvar = bracket lock unlock rotateFiles
237  where
238    lock           = tryTakeMVar mvar
239    unlock Nothing = return ()
240    unlock (Just lgrset) = do
241        let (newlgrset, current_path) = replaceLoggerSet lgrset new_file_path
242        putMVar mvar newlgrset
243        case current_path of
244          Nothing   -> return ()
245          Just path -> timed_post_process spec path
246    rotateFiles Nothing  = return ()
247    rotateFiles (Just lgrset) = do
248        let (newlgrset, _) = replaceLoggerSet lgrset new_file_path
249        renewLoggerSet newlgrset
250    new_file_path = prefixTime now $ timed_log_file spec
251