-
Notifications
You must be signed in to change notification settings - Fork 8
/
Logging.hs
364 lines (303 loc) · 10.9 KB
/
Logging.hs
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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Quick example of how to use this module:
--
-- @
-- import Control.Logging
--
-- main = withStdoutLogging $ do
-- log "This is a log message!"
-- timedLog "This is a timed log message!" $ threadDelay 100000
-- @
module Control.Logging
( log
, log'
, logS
, logS'
, warn
, warn'
, warnS
, warnS'
, debug
, debug'
, debugS
, debugS'
, errorL
, errorL'
, errorSL
, errorSL'
, traceL
, traceL'
, traceSL
, traceSL'
, traceShowL
, traceShowL'
, traceShowSL
, traceShowSL'
, timedLog
, timedLog'
, timedLogS
, timedLogS'
, timedLogEnd
, timedLogEnd'
, timedLogEndS
, timedLogEndS'
, timedDebug
, timedDebug'
, timedDebugS
, timedDebugS'
, timedDebugEnd
, timedDebugEnd'
, timedDebugEndS
, timedDebugEndS'
, withStdoutLogging
, withStderrLogging
, withFileLogging
, flushLog
, loggingLogger
, setLogLevel
, setLogTimeFormat
, setDebugSourceRegex
, LogLevel (..)
) where
import Control.Exception.Lifted
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Data.Functor ((<$))
import Data.IORef
import Data.Maybe (isJust)
import Data.Monoid
import Data.Text as T
import Data.Time
import Data.Time.Locale.Compat (defaultTimeLocale)
import Prelude hiding (log)
import System.IO.Unsafe
import System.Log.FastLogger
import Text.Regex (Regex, mkRegex, matchRegex)
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
deriving (Eq, Prelude.Show, Prelude.Read, Ord)
type LogSource = Text
logLevel :: IORef LogLevel
{-# NOINLINE logLevel #-}
logLevel = unsafePerformIO $ newIORef LevelDebug
-- | Set the verbosity level. Messages at our higher than this level are
-- displayed. It defaults to 'LevelDebug'.
setLogLevel :: LogLevel -> IO ()
setLogLevel = atomicWriteIORef logLevel
logSet :: IORef LoggerSet
{-# NOINLINE logSet #-}
logSet = unsafePerformIO $
newIORef (error "Must call withStdoutLogging or withStderrLogging")
logTimeFormat :: IORef String
{-# NOINLINE logTimeFormat #-}
logTimeFormat = unsafePerformIO $ newIORef "%F %T"
-- | Set the format used for log timestamps.
setLogTimeFormat :: String -> IO ()
setLogTimeFormat = atomicWriteIORef logTimeFormat
debugSourceRegexp :: IORef (Maybe Regex)
{-# NOINLINE debugSourceRegexp #-}
debugSourceRegexp = unsafePerformIO $ newIORef Nothing
-- | When printing 'LevelDebug' messages, only display those matching the
-- given regexp applied to the Source parameter. Calls to 'debug' without a
-- source parameter are regarded as having a source of @""@.
setDebugSourceRegex :: String -> IO ()
setDebugSourceRegex =
atomicWriteIORef debugSourceRegexp
. Just
. mkRegex
loggingLogger :: ToLogStr msg => LogLevel -> LogSource -> msg -> IO ()
loggingLogger !lvl !src str = do
maxLvl <- readIORef logLevel
when (lvl >= maxLvl) $ do
mre <- readIORef debugSourceRegexp
let willLog = case mre of
Nothing -> True
Just re -> lvl /= LevelDebug || isJust (matchRegex re (T.unpack src))
when willLog $ do
now <- getZonedTime
fmt <- readIORef logTimeFormat
let stamp = formatTime defaultTimeLocale fmt now
set <- readIORef logSet
pushLogStr set
$ toLogStr (stamp ++ " " ++ renderLevel lvl
++ " " ++ renderSource src)
<> toLogStr str
<> toLogStr (pack "\n")
where
renderSource :: Text -> String
renderSource txt
| T.null txt = ""
| otherwise = unpack txt ++ ": "
renderLevel LevelDebug = "[DEBUG]"
renderLevel LevelInfo = "[INFO]"
renderLevel LevelWarn = "[WARN]"
renderLevel LevelError = "[ERROR]"
renderLevel (LevelOther txt) = "[" ++ unpack txt ++ "]"
-- | This function, or 'withStderrLogging', must be wrapped around whatever
-- region of your application intends to use logging. Typically it would be
-- wrapped around the body of 'main'.
withStdoutLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a
withStdoutLogging f = do
liftIO $ do
set <- newStdoutLoggerSet defaultBufSize
atomicWriteIORef logSet set
f `finally` flushLog
withStderrLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a
withStderrLogging f = do
liftIO $ do
set <- newStderrLoggerSet defaultBufSize
atomicWriteIORef logSet set
f `finally` flushLog
withFileLogging :: (MonadBaseControl IO m, MonadIO m) => FilePath -> m a -> m a
withFileLogging path f = do
liftIO $ do
set <- newFileLoggerSet defaultBufSize path
atomicWriteIORef logSet set
f `finally` flushLog
-- | Flush all collected logging messages. This is automatically called by
-- 'withStdoutLogging' and 'withStderrLogging' when those blocks are exited
-- by whatever means.
flushLog :: MonadIO m => m ()
flushLog = liftIO $ do
set <- readIORef logSet
flushLogStr set
-- You must surround the body of your @main@ function with a call to
-- 'withStdoutLogging' or 'withStderrLogging', to ensure that all logging
-- buffers are properly flushed on exit.
log :: Text -> IO ()
log = loggingLogger LevelInfo ""
logError :: Text -> Text -> IO ()
logError = loggingLogger LevelError
logS :: Text -> Text -> IO ()
logS = loggingLogger LevelInfo
-- | The apostrophe varients of the logging functions flush the log after each
-- message.
log' :: MonadIO m => Text -> m ()
log' msg = liftIO (log msg) >> flushLog
logS' :: MonadIO m => Text -> Text -> m ()
logS' src msg = liftIO (logS src msg) >> flushLog
debug :: Text -> IO ()
debug = debugS ""
debugS :: Text -> Text -> IO ()
debugS = loggingLogger LevelDebug
debug' :: MonadIO m => Text -> m ()
debug' msg = liftIO (debug msg) >> flushLog
debugS' :: MonadIO m => Text -> Text -> m ()
debugS' src msg = liftIO (debugS src msg) >> flushLog
warn :: Text -> IO ()
warn = warnS ""
warnS :: Text -> Text -> IO ()
warnS = loggingLogger LevelWarn
warn' :: MonadIO m => Text -> m ()
warn' msg = liftIO (warn msg) >> flushLog
warnS' :: MonadIO m => Text -> Text -> m ()
warnS' src msg = liftIO (warnS src msg) >> flushLog
-- | A logging variant of 'error' which uses 'unsafePerformIO' to output a log
-- message before calling 'error'.
errorL :: Text -> a
errorL str = error (unsafePerformIO (logError "" str) `seq` unpack str)
errorL' :: Text -> a
errorL' str = error (unsafePerformIO (logError "" str >> flushLog) `seq` unpack str)
errorSL :: Text -> Text -> a
errorSL src str = error (unsafePerformIO (logError src str) `seq` unpack str)
errorSL' :: Text -> Text -> a
errorSL' src str =
error (unsafePerformIO (logError src str >> flushLog) `seq` unpack str)
traceL :: Text -> a -> a
traceL str x = unsafePerformIO (debug str) `seq` x
traceL' :: Text -> a -> a
traceL' str x = unsafePerformIO (debug str >> flushLog) `seq` x
traceSL :: Text -> Text -> a -> a
traceSL src str x = unsafePerformIO (debugS src str) `seq` x
traceSL' :: Text -> Text -> a -> a
traceSL' src str x =
unsafePerformIO (debugS src str >> flushLog) `seq` x
traceShowL :: Show a => a -> a
traceShowL x =
let s = show x
in unsafePerformIO (debug (pack s)) `seq` x
traceShowL' :: Show a => a -> a
traceShowL' x =
let s = show x
in unsafePerformIO (debug (pack s) >> flushLog) `seq` x
traceShowSL :: Show a => Text -> a -> a
traceShowSL src x =
let s = show x
in unsafePerformIO (debugS src (pack s)) `seq` x
traceShowSL' :: Show a => Text -> a -> a
traceShowSL' src x =
let s = show x
in unsafePerformIO (debugS src (pack s) >> flushLog) `seq` x
doTimedLog :: (MonadBaseControl IO m, MonadIO m)
=> (Text -> IO ()) -> Bool -> Text -> m a -> m a
doTimedLog logf wrapped msg f = do
start <- liftIO getCurrentTime
when wrapped $ (liftIO . logf) $ msg <> "..."
res <- f `catch` \e -> do
let str = show (e :: SomeException)
wrapup start $ pack $
if wrapped
then "...FAIL (" ++ str ++ ")"
else " (FAIL: " ++ str ++ ")"
throwIO e
wrapup start $ if wrapped then "...done" else ""
return res
where
wrapup start m = do
end <- liftIO getCurrentTime
liftIO . logf $ msg <> m <> " [" <> pack (show (diffUTCTime end start)) <> "]"
-- | Output a logging message both before an action begins, and after it ends,
-- reporting the total length of time. If an exception occurred, it is also
-- reported.
timedLog :: (MonadBaseControl IO m, MonadIO m)
=> Text -> m a -> m a
timedLog = doTimedLog log True
timedLog' :: (MonadBaseControl IO m, MonadIO m)
=> Text -> m a -> m a
timedLog' msg f = doTimedLog log True msg f >>= (<$ flushLog)
timedLogS :: (MonadBaseControl IO m, MonadIO m)
=> Text -> Text -> m a -> m a
timedLogS src = doTimedLog (logS src) True
timedLogS' :: (MonadBaseControl IO m, MonadIO m)
=> Text -> Text -> m a -> m a
timedLogS' src msg f = doTimedLog (logS src) True msg f >>= (<$ flushLog)
-- | Like 'timedLog', except that it does only logs when the action has
-- completed or failed after it is done.
timedLogEnd :: (MonadBaseControl IO m, MonadIO m)
=> Text -> m a -> m a
timedLogEnd = doTimedLog log False
timedLogEnd' :: (MonadBaseControl IO m, MonadIO m)
=> Text -> m a -> m a
timedLogEnd' msg f = doTimedLog log False msg f >>= (<$ flushLog)
timedLogEndS :: (MonadBaseControl IO m, MonadIO m)
=> Text -> Text -> m a -> m a
timedLogEndS src = doTimedLog (logS src) False
timedLogEndS' :: (MonadBaseControl IO m, MonadIO m)
=> Text -> Text -> m a -> m a
timedLogEndS' src msg f = doTimedLog (logS src) False msg f >>= (<$ flushLog)
-- | A debug variant of 'timedLog'.
timedDebug :: (MonadBaseControl IO m, MonadIO m)
=> Text -> m a -> m a
timedDebug = doTimedLog debug True
timedDebug' :: (MonadBaseControl IO m, MonadIO m)
=> Text -> m a -> m a
timedDebug' msg f = doTimedLog debug True msg f >>= (<$ flushLog)
timedDebugS :: (MonadBaseControl IO m, MonadIO m)
=> Text -> Text -> m a -> m a
timedDebugS src = doTimedLog (debugS src) True
timedDebugS' :: (MonadBaseControl IO m, MonadIO m)
=> Text -> Text -> m a -> m a
timedDebugS' src msg f = doTimedLog (debugS src) True msg f >>= (<$ flushLog)
timedDebugEnd :: (MonadBaseControl IO m, MonadIO m)
=> Text -> m a -> m a
timedDebugEnd = doTimedLog debug False
timedDebugEnd' :: (MonadBaseControl IO m, MonadIO m)
=> Text -> m a -> m a
timedDebugEnd' msg f = doTimedLog debug False msg f >>= (<$ flushLog)
timedDebugEndS :: (MonadBaseControl IO m, MonadIO m)
=> Text -> Text -> m a -> m a
timedDebugEndS src = doTimedLog (debugS src) False
timedDebugEndS' :: (MonadBaseControl IO m, MonadIO m)
=> Text -> Text -> m a -> m a
timedDebugEndS' src msg f = doTimedLog (debugS src) False msg f >>= (<$ flushLog)