summaryrefslogtreecommitdiff
path: root/src/Lumberjack.hs
blob: e6f780ec5533b5533443fa23a41e5d6cd9475111 (plain)
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
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-------------------------------------------
-- |
-- Module      : Lumberjack
-- Copyright   : (c) Galois Inc. 2020
-- Maintainer  : kquick@galois.com
-- Stability   : experimental
-- Portability : POSIX
-- |
--
-- This module defines a general logging facility that can be used to
-- output log messages to various targets.
-------------------------------------------

module Lumberjack
  ( -- * Interface for Logging
    LogAction(..)
  , HasLog(..)
  , LoggingMonad(..)
  , writeLogM
    -- * Logging Utilities
  , safeLogAction
  , logFilter
    -- * Default LogMessage
  , Severity(..)
  , LogType(..)
  , LogMessage(..)
  , msgWith
  , WithLog
  , withLogTag
  , addLogActionTime
    -- * Output formatting for LogMessage
  , cvtLogMessageToPlainText
  , cvtLogMessageToANSITermText
    -- * Helpers and convenience functions
  , logFunctionCall, logFunctionCallM
  , logProgress, logProgressM
  , tshow
  , defaultGetIOLogAction
  )
where

import qualified Control.Monad.Catch as X
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Data.Functor.Contravariant
import           Data.Functor.Contravariant.Divisible
import           Data.Monoid hiding ( (<>) )
import           Data.Semigroup
import           Data.Text ( Text, pack, empty )
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as PP_Term
import qualified Data.Text.Prettyprint.Doc.Render.Text as PP_Text
import           Data.Time.Clock ( UTCTime(..), getCurrentTime, diffUTCTime )
import           Data.Time.Format ( defaultTimeLocale, formatTime )
import           Data.Void
import           System.IO ( stderr )

import           Prelude


-- ----------------------------------------------------------------------
-- * Interface for Logging
--
-- The 'LogAction' is the fundamental operation that decides how to
-- log a provided message.
--
-- Code wishing to output a logged message simply uses the LogAction
-- object:
--
-- > writeLog action msg
--
-- For convenience, the LogAction can be stored in the local operating
-- monad context, from which it can be retrieved (and modified).  A
-- monad which can supply a LogAction is a member of the HasLog class,
-- and the 'writeLogM' function will automatically retrieve the
-- LogAction from the monad and write to it:
--
-- > writeLogM msg
--
-- LogActions can be combined via Semigroup operations (<>) and the
-- resulting LogAction will perform both actions with each message.
-- The Monoidal mempty LogAction simply does nothing.  For example,
-- logging to both a file and stdout can be done by @logToFile <>
-- logToStdout@.
--
-- LogActions are also Contravariant (and Divisible and Decidable) to
-- allow easy conversion of a LogAction for the base message type into
-- a LogAction for a different message type (or types) that can be
-- converted to (and combined into) the base message type.

-- | The LogAction holds the ability to log a message of type 'msg'
-- (the second parameter) via a monad 'm' (the first parameter).
--
-- LogActions are semigroup and monoid combineable, which results in
-- both LogActions being taken (or no action in the case of mempty),
-- and contravariant to allow the msg to be modified via function
-- prior to being logged (as well as Divisible and Decidable).
newtype LogAction m msg = LogAction { writeLog :: msg -> m () }

instance Applicative m => Semigroup (LogAction m a) where
  LogAction a1 <> LogAction a2 = LogAction $ \a -> a1 a *> a2 a

instance Applicative m => Monoid (LogAction m a) where
  mappend = (<>)
  mempty = LogAction $ \_ -> pure ()

instance Contravariant (LogAction m) where
  contramap f (LogAction a) = LogAction $ a . f

instance (Applicative m) => Divisible (LogAction m) where
  conquer = LogAction $ \_ -> pure ()
  divide splitf lLog rLog = LogAction $ \i ->
    let (l, r) = splitf i
        ll = writeLog lLog l
        rl = writeLog rLog r
    in ll *> rl

instance (Applicative m) => Decidable (LogAction m) where
  lose f = LogAction $ \a -> absurd (f a)
  choose split l r = LogAction $ either (writeLog l) (writeLog r) . split

-- | Any monad which will support retrieving or adjusting a LogAction
-- must support the 'HasLog' class.
class Monad m => HasLog msg m where
  getLogAction :: m (LogAction m msg)

class (Monad m, HasLog msg m) => LoggingMonad msg m where
  adjustLogAction :: (forall k. LogAction k msg -> LogAction k msg) -> m a -> m a


-- | This invokes the LogAction's logging handler in a monadic context
-- where the logging handler can be retrieved via the 'HasLog' class's
-- 'getLogAction' function.
writeLogM :: HasLog msg m => msg -> m ()
writeLogM m = getLogAction >>= flip writeLog m


----------------------------------------------------------------------
-- * LogAction Utilities
--
-- The following utility functions can be used to adjust or wrap
-- LogActions to provide additional functionality.

-- | Ensures that the LogAction does not fail if the logging operation
-- itself throws an exception (the exception is ignored).
safeLogAction :: X.MonadCatch m => LogAction m msg -> LogAction m msg
safeLogAction a = LogAction $ \m -> X.catch (writeLog a m) (\(_ex :: X.SomeException) -> return ())

-- | The logFilter can be used on a LogAction to determine which
-- messages the LogAction should be invoked for (only those for which
-- the filter function returns True).
logFilter :: Applicative m => (msg -> Bool) -> LogAction m msg -> LogAction m msg
logFilter f (LogAction l) = LogAction $ \m -> when (f m) (l m)



----------------------------------------------------------------------
-- * Default LogMessage
--
-- This is the default 'msg' type for the LogAction, containing the
-- various information associated with the logging to be performed.

-- | The Severity indicates the relative importance of the logging
-- message.  This can be useful for filtering log messages.
data Severity = Debug | Info | Warning | Error deriving (Ord, Eq, Show)

-- | The LogType indicates what type of message this is.  These are
-- printed on the log line and can be used for filtering different
-- types of log messages.
data LogType = Progress | FuncEntry | FuncExit | MiscLog | UserOp
  deriving (Eq, Show)

-- | Each logged output is described by a LogMessage object.
data LogMessage = LogMessage { logType :: LogType
                             , logLevel :: Severity
                             , logTime :: UTCTime
                             , logTags :: [(Text, Text)]
                             , logText :: Text
                             }

instance Semigroup LogMessage where
  a <> b = LogMessage { logType = if logType a == MiscLog then logType b else logType a
                      , logLevel = max (logLevel a) (logLevel b)
                      , logTime = max (logTime a) (logTime b)
                      , logTags = logTags a <> logTags b
                      , logText = case (T.null (logText a), T.null (logText b)) of
                                  (False, False) -> logText a <> "; " <> logText b
                                  (True, False) -> logText b
                                  _ -> logText a
                      }

instance Monoid LogMessage where
  mempty = LogMessage MiscLog Debug (UTCTime (toEnum 0) (toEnum 0)) [] empty
  mappend = (<>)

-- | Helper routine to return an empty LogMessage, whose fields can
-- then be updated.
msgWith :: LogMessage
msgWith = mempty


-- | Add the current timestamp to the LogMessage being logged
addLogActionTime :: MonadIO m => LogAction m LogMessage -> LogAction m LogMessage
addLogActionTime a = LogAction $ \m -> do t <- liftIO getCurrentTime
                                          writeLog a $ m <> mempty { logTime = t }


-- | This type is a Constraint that should be applied to any client
-- function that will perform logging in a monad context.  The 'msg'
-- is the type of message that will be logged, and the 'm' is the
-- monad under which the logging is performed.
type WithLog msg m = ({- X.MonadCatch m, -} HasLog msg m)


-- | Log messages can have any number of key/value tags applied to
-- them.  This function establishes a new key/value tag pair that will
-- be in effect for the monadic operation passed as the third
-- argument.
-- withLogTag tname tval op = local (adjustLogAction $ addLogTag tname tval) op
withLogTag :: (LoggingMonad LogMessage m) => Text -> Text -> m a -> m a
withLogTag tname tval op =
    let tagmsg = mempty { logTags = [(tname, tval)] }
    in (adjustLogAction $ contramap (tagmsg <>)) op


-- ----------------------------------------------------------------------
-- * Output formatting for LogMessage
--
-- Optimal LogMessage formatting uses prettyprinter output with a
-- 'PrettyLogAnn' annotation type which assigns different annotations
-- to different parts of the log message.  This is achieved by calling
-- 'prettyLogMessage'.
--
-- Alternatively, the 'Pretty' class 'pretty'
-- method can be used to get log message formatting for generic
-- annotation types, but the different parts of the message will not
-- be distinguished via annotation values.

data PrettyLogAnn = AnnLogType LogType
                  | AnnSeverity Severity
                  | AnnTime
                  | AnnTimeMinSec
                  | AnnTag
                  | AnnTagVal

-- Use prettyLogType instead
instance PP.Pretty LogType where pretty = anyPrettyLogType

anyPrettyLogType :: LogType -> PP.Doc ann
anyPrettyLogType Progress  = PP.pretty ("progress" :: Text)
anyPrettyLogType FuncEntry = PP.pretty ("entered" :: Text)
anyPrettyLogType FuncExit  = PP.pretty ("completed" :: Text)
anyPrettyLogType UserOp    = PP.pretty ("User-Op" :: Text)
anyPrettyLogType MiscLog   = PP.pretty ("misc" :: Text)

prettyLogType :: LogType -> PP.Doc PrettyLogAnn
prettyLogType t = PP.annotate (AnnLogType t) $ anyPrettyLogType t

-- Use prettySev instead
instance PP.Pretty Severity where pretty = anyPrettySev

anyPrettySev :: Severity -> PP.Doc ann
anyPrettySev Error   = PP.pretty ("ERR " :: Text)
anyPrettySev Warning = PP.pretty ("Warn" :: Text)
anyPrettySev Info    = PP.pretty ("I   " :: Text)
anyPrettySev Debug   = PP.pretty ("Dbg " :: Text)

prettySev :: Severity -> PP.Doc PrettyLogAnn
prettySev s = PP.annotate (AnnSeverity s) $ anyPrettySev s

-- Use prettyTime instead
instance PP.Pretty UTCTime where
  pretty t = PP.hcat [ PP.pretty (formatTime defaultTimeLocale "%Z-%F:%H:" t)
                     , PP.pretty (formatTime defaultTimeLocale "%M:%S" t)
                     , PP.pretty (take 4 (formatTime defaultTimeLocale ".%q" t))
                     ]

prettyTime :: UTCTime -> PP.Doc PrettyLogAnn
prettyTime t =
  if t == UTCTime (toEnum 0) (toEnum 0)
  then PP.annotate AnnTime $ PP.emptyDoc
  else PP.hcat
       [ PP.annotate AnnTime $ PP.pretty (formatTime defaultTimeLocale "%Z-%F_%H:" t)
       , PP.annotate AnnTimeMinSec $ PP.pretty (formatTime defaultTimeLocale "%M:%S" t)
       , PP.annotate AnnTime $ PP.pretty (take 4 (formatTime defaultTimeLocale ".%q" t))
       ]

anyPrettyTags :: [(Text, Text)] -> PP.Doc ann
anyPrettyTags =
  let anyPrettyTag (tag, val) = PP.group $ PP.cat [ PP.pretty tag
                                                  , PP.equals
                                                  , PP.pretty val
                                                  ]
  in foldl (\acc tagval -> acc PP.<+> (anyPrettyTag tagval)) mempty

prettyTags :: [(Text, Text)] -> PP.Doc PrettyLogAnn
prettyTags =
  let ppTag (tag, val) = PP.group $ PP.hcat [ PP.annotate AnnTag $ PP.pretty tag
                                            , PP.equals
                                            , PP.annotate AnnTagVal $ PP.pretty val
                                            ]
  in foldl (\acc tagval -> acc PP.<+> (ppTag tagval)) mempty

-- | Format the log message with annotation values designating the
-- different portions of the pretty-printed value.
--
-- The 'Pretty' class 'pretty' method can be used for generic
-- annotations, but this yields less information for output management.
prettyLogMessage :: LogMessage -> PP.Doc PrettyLogAnn
prettyLogMessage (LogMessage {..}) = PP.hsep [ prettyTime logTime
                                             , prettySev logLevel
                                             , PP.brackets (prettyLogType logType)
                                             , prettyTags logTags
                                             , PP.pretty logText
                                             ]

instance PP.Pretty LogMessage where
  pretty (LogMessage {..}) = PP.hsep [ PP.pretty logTime
                                     , PP.pretty logLevel
                                     , PP.brackets (PP.pretty logType)
                                     , anyPrettyTags logTags
                                     , PP.pretty logText
                                     ]


-- | The 'termStyle' converts the LogMessage annotations into ANSI
-- terminal styles to add colors and other effects such as bolding to
-- various portions of log messages (for use with
-- prettyprinter-ansi-terminal).
termStyle :: PrettyLogAnn -> PP_Term.AnsiStyle
termStyle (AnnLogType Progress)  = PP_Term.colorDull PP_Term.Green
termStyle (AnnLogType FuncEntry) = PP_Term.colorDull PP_Term.Magenta
termStyle (AnnLogType FuncExit)  = PP_Term.colorDull PP_Term.Cyan
termStyle (AnnLogType UserOp)    = PP_Term.bold <> PP_Term.color PP_Term.Green
termStyle (AnnLogType MiscLog)   = mempty
termStyle (AnnSeverity Error)   = PP_Term.bold <> PP_Term.color PP_Term.Red <> PP_Term.bgColor PP_Term.Yellow
termStyle (AnnSeverity Warning) = PP_Term.bold <> PP_Term.colorDull PP_Term.Red
termStyle (AnnSeverity Info)    = mempty
termStyle (AnnSeverity Debug)   = PP_Term.color PP_Term.Blue
termStyle AnnTime       = mempty
termStyle AnnTimeMinSec = PP_Term.color PP_Term.White <> PP_Term.bold
termStyle AnnTag    = PP_Term.color PP_Term.Black <> PP_Term.bold
termStyle AnnTagVal = PP_Term.color PP_Term.Black <> PP_Term.bold


-- | Standard function to convert a LogMessage into Text with ANSI
-- terminal colors and bolding and other styling.  This can be used as
-- the default converter for a logger (via contramap).
cvtLogMessageToANSITermText :: LogMessage -> Text
cvtLogMessageToANSITermText = PP_Term.renderStrict .
                              PP.reAnnotateS termStyle .
                              PP.layoutSmart PP.defaultLayoutOptions .
                              prettyLogMessage

-- | Standard function for converting a LogMessage into plain Text (no
-- colors or bolding, just text).  This can be used as the default
-- converter for a logger (via contramap).
cvtLogMessageToPlainText :: LogMessage -> Text
cvtLogMessageToPlainText = PP_Text.renderStrict .
                           PP.layoutSmart PP.defaultLayoutOptions .
                           prettyLogMessage

-- ----------------------------------------------------------------------
-- * Helpers and convenience functions
--
-- These functions are not part of the core Logging implementation,
-- but can be useful to clients to perform common or default
-- operations.

-- | A wrapper for a monadic function call that will log on entry
-- (Debug) and exit (Info) from the function, and note the total
-- amount of time taken during execution of the function.  Note that
-- no strictness is applied to the internal monadic operation, so the
-- time taken may be misleading.  Like 'logFunctionCallM' but needs an
-- explicit 'LogAction' whereas 'logFunctionCallM' will retrieve the
-- 'LogAction' from the current monadic context.
logFunctionCall :: (MonadIO m) => LogAction m LogMessage -> Text -> m a -> m a
logFunctionCall = logFunctionCallWith . writeLog

-- | A wrapper for a monadic function call that will log on entry
-- (Debug) and exit (Info) from the function, and note the total
-- amount of time taken during execution of the function.  Note that
-- no strictness is applied to the internal monadic operation, so the
-- time taken may be misleading.
logFunctionCallM :: (MonadIO m, WithLog LogMessage m) => Text -> m a -> m a
logFunctionCallM = logFunctionCallWith writeLogM

-- | Internal function implementing the body for 'logFunctionCall' or
-- 'logFunctionCallM'
logFunctionCallWith :: (MonadIO m) => (LogMessage -> m ()) -> Text -> m a -> m a
logFunctionCallWith logger fName f =
  do logger $ msgWith { logType = FuncEntry, logText = fName }
     t <- liftIO getCurrentTime
     r <- f
     t' <- liftIO getCurrentTime
     let dt = diffUTCTime t' t
     logger $ msgWith { logType = FuncExit, logLevel = Info
                      , logText = fName <> ", executed for " <> pack (show dt) }
     return r


-- | Called to output a log message to indicate that some progress has
-- been made.
logProgress :: (MonadIO m) => LogAction m LogMessage -> Text -> m ()
logProgress action txt = writeLog action $ msgWith { logLevel = Info, logType = Progress, logText = txt }


-- | Called to output a log message within a Logging monad to indicate
-- that some progress has been made.
logProgressM :: (MonadIO m, WithLog LogMessage m) => Text -> m ()
logProgressM txt = writeLogM $ msgWith { logLevel = Info, logType = Progress, logText = txt }


-- | This is a helper because the LogMessage normally wants a Text,
-- but show delivers a String.
tshow :: (Show a) => a -> Text
tshow = pack . show


-- | When using a simple IO monad, there is no ability to store a
-- LogAction in the base monad.  The client can specify a specific
-- HasLog instance for IO that is appropriate to that client, and that
-- HasLog can optionally use the 'defaultGetIOLogAction' as the
-- 'getLogAction' implementation to log pretty messages with ANSI
-- styling to stdout.
--
--  > instance HasLog Env Text IO where
--  >     getLogAction = return defaultGetIOLogAction
--  >     ...
defaultGetIOLogAction :: MonadIO m => LogAction m T.Text
defaultGetIOLogAction = LogAction $ liftIO . TIO.hPutStrLn stderr