git.iko.soy/typeable/control-logger
on B2H-1431 help sign in
typeable/control-logger/src/Control/Logger.hs
289 lines 8.0 kB history raw
1{-# LANGUAGE CPP #-}
2module Control.Logger
3 ( Logger
4 , loggerContext
5 , scrubber
6 , censor
7 , censorWith
8 , logMsg
9 , logMsgWith
10 , logInfo
11 , logDebug
12 , logWarn
13 , logError
14 , logInfoWith
15 , logDebugWith
16 , logWarnWith
17 , logErrorWith
18 , tryLogError
19 , tryJustLog
20 , tryJustWarn
21 , logExceptions
22 , LogSeverity(..)
23 , renderLogLevel
24 , parseLogLevel
25 , oneoffLog
26 , LoggingMonad
27 , LogSource
28 , fileLogger
29 , silentLogger
30 , flushingFastFunc
31 , flushingStderrLogger
32 , stderrLogger
33 , stdoutLogger
34 , defaultFastFunc
35 , compactCallStack
36 , st
37 , ToObject(..)
38 , withScrubber
39 , censoringWith
40 , censoring
41 ) where
43import Control.Has
44import Control.Lens hiding (censoring)
45import Control.Logger.Internal
46import Control.Logger.Orphans ()
47import Control.Monad.Catch
48import qualified Data.List as List
49import Data.Monoid
50import Data.Text (Text)
51import qualified Data.Text as Text
52import Data.Time
53import GHC.Stack
54import Katip (ToObject (..))
55import System.Log.FastLogger
56import Text.Shakespeare.Text (st)
57-- import Control.Monad.RWS (censor)
58#if MIN_VERSION_mtl(2,3,0)
59import Control.Monad
60import Control.Monad.IO.Class
61#endif
63logError
64 :: (LoggingMonad r m)
65 => Text
66 -> m ()
67logError msg = withFrozenCallStack (logMsg Error msg)
69logDebug
70 :: (LoggingMonad r m)
71 => Text
72 -> m ()
73logDebug msg = withFrozenCallStack (logMsg Debug msg)
75logInfo
76 :: (LoggingMonad r m)
77 => Text
78 -> m ()
79logInfo msg = withFrozenCallStack (logMsg Info msg)
81logWarn
82 :: (LoggingMonad r m)
83 => Text
84 -> m ()
85logWarn msg = withFrozenCallStack (logMsg Warn msg)
87logInfoWith
88 :: (MonadIO m, HasCallStack)
89 => Logger
90 -> Text
91 -> m ()
92logInfoWith logger msg = withFrozenCallStack (logMsgWith logger Info msg)
94logDebugWith
95 :: (MonadIO m, HasCallStack)
96 => Logger
97 -> Text
98 -> m ()
99logDebugWith logger msg = withFrozenCallStack (logMsgWith logger Debug msg)
101logWarnWith
102 :: (MonadIO m, HasCallStack)
103 => Logger
104 -> Text
105 -> m ()
106logWarnWith logger msg = withFrozenCallStack (logMsgWith logger Warn msg)
108logErrorWith
109 :: (MonadIO m, HasCallStack)
110 => Logger
111 -> Text
112 -> m ()
113logErrorWith logger msg = withFrozenCallStack (logMsgWith logger Error msg)
115safeReplace :: Text -> Text -> Text -> Text
116safeReplace what with where_
117 | Text.null what = where_
118 | otherwise = Text.replace what with where_
120-- | Add a some text to scrubber
121censorWith :: Text -> Text -> Logger -> Logger
122censorWith replacement needle l =
123 l & scrubber <>~ Endo (safeReplace needle replacement)
125-- | Censor with "***"
126censor :: Text -> Logger -> Logger
127censor = censorWith "***"
129-- | Run an action with adjusted scrubber
130withScrubber
131 :: forall r m a. (Has Logger r, MonadReader r m)
132 => (Endo Text -> Endo Text)
133 -> m a
134 -> m a
135withScrubber scrubF = local expandScrubber
136 where
137 expandScrubber :: r -> r
138 expandScrubber = over part (over scrubber scrubF)
140-- | Run an action while censoring additional text from logs
141censoringWith
142 :: (Has Logger r, MonadReader r m)
143 => Text
144 -> Text
145 -> m a
146 -> m a
147censoringWith replacement txt = withScrubber (<> censored)
148 where
149 censored = Endo (safeReplace txt replacement)
151-- | Run an action while censoring additional text from logs
152censoring
153 :: (Has Logger r, MonadReader r m)
154 => Text
155 -> m a
156 -> m a
157censoring = censoringWith "***"
159-- | Log exceptions occured in computation and just ignore them.
160tryLogError
161 :: (MonadIO m, MonadCatch m, Has Logger r, MonadReader r m)
162 => m ()
163 -> m ()
164tryLogError a = try a >>= \case
165 Left (e :: SomeException) -> logError . Text.pack $ show e
166 Right x -> return x
168tryJustLog
169 :: (MonadIO m, MonadCatch m, Has Logger r, MonadReader r m)
170 => m a
171 -> (Text -> Text)
172 -- ^ generates error message from exception type + exception text
173 -> m (Maybe a)
174tryJustLog action genMsg = do
175 let
176 logAll :: SomeException -> Maybe SomeException
177 logAll = Just
178 errorHandler (SomeException e) =
179 logError (genMsg $ Text.pack $ show e) >> pure Nothing
180 catchJust logAll (Just <$> action) errorHandler
182tryJustWarn
183 :: (MonadIO m, Has Logger r, MonadCatch m, MonadReader r m)
184 => m a
185 -> (Text -> Text)
186 -- ^ generates warning message from exception type + exception text
187 -> m (Maybe a)
188tryJustWarn action genMsg = do
189 let
190 logAll :: SomeException -> Maybe SomeException
191 logAll = Just
192 errorHandler (SomeException e) =
193 logWarn (genMsg $ Text.pack $ show e) >> pure Nothing
194 catchJust logAll (Just <$> action) errorHandler
196logExceptions :: (MonadCatch m, MonadThrow m, LoggingMonad r m) => m a -> m a
197logExceptions ma = catch ma $ \e -> do
198 logError $ (Text.pack . show) (e :: SomeException)
199 throwM e
201oneoffLog :: MonadIO m => Logger -> LogSeverity -> Text -> m ()
202oneoffLog logger s t =
203 withFrozenCallStack (flip runReaderT logger $ logMsg s t)
205fileLogger :: MonadIO m => FilePath -> m Logger
206fileLogger fp = fastFunc <$> liftIO (newFileLoggerSet defaultBufSize fp)
208silentLogger :: Logger
209silentLogger = Logger mempty mempty (\_ _ _ _ -> return ())
211-- | Logger which flushes buffer after each message. This is useful with
212-- stderrLogger.
213flushingFastFunc
214 :: LogSeverity -> LoggerSet -> Logger
215flushingFastFunc minLogLevel loggerSet =
216 Logger mempty mempty $ \_ stack logLevel msg ->
217 when (logLevel >= minLogLevel) $ do
218 ts <- getCurrentTime
219 pushLogStr loggerSet
220 $ formatLogStr ts stack mempty logLevel (toLogStr msg)
221 flushLogStr loggerSet
223-- | Used only in tests.
224stderrLogger :: MonadIO m => LogSource -> m Logger
225stderrLogger loc =
226 defaultFastFunc loc Debug <$> liftIO (newStderrLoggerSet defaultBufSize)
228stdoutLogger :: MonadIO m => LogSource -> m Logger
229stdoutLogger loc =
230 defaultFastFunc loc Debug <$> liftIO (newStdoutLoggerSet defaultBufSize)
232-- | same as 'stderrLogger' but flushes buffer after each line.
233flushingStderrLogger :: MonadIO m => m Logger
234flushingStderrLogger =
235 flushingFastFunc Debug <$> liftIO (newStderrLoggerSet defaultBufSize)
237-- | Make our outdated 'Logger' of fast-logger's 'LoggerSet'
238fastFunc :: LoggerSet -> Logger
239fastFunc loggerSet =
240 Logger mempty mempty $ \_ _ _ msg -> pushLogStr loggerSet $ toLogStr msg
242type LogSource = Text
244-- | Default logger tests and same things.
245defaultFastFunc :: LogSource -> LogSeverity -> LoggerSet -> Logger
246defaultFastFunc loc minLogLevel loggerSet =
247 Logger mempty mempty $ \_ stack s msg -> when (s >= minLogLevel) $ do
248 ts <- getCurrentTime
249 pushLogStr loggerSet $ formatLogStr ts stack loc s (toLogStr msg)
251-- | Prepends to 'LogStr' string with "[time][log-level]". Used for
252-- text logs only
253formatLogStr
254 :: UTCTime -> CallStack -> LogSource -> LogSeverity -> LogStr -> LogStr
255formatLogStr ts _ src level msg =
256 "[" <> tsStr <> "][" <> levelStr <> srcStr <> "] " <> msg <> "\n"
257 where
258 srcStr = if Text.null src then mempty else "#" <> toLogStr src
259 -- TODO: time-1.8 support padding: %6Q (microseconds)
260 tsStr = toLogStr $ formatTime defaultTimeLocale "%FT%T%Q" ts
261 levelStr = case level of
262 Debug -> "DEBUG"
263 Info -> "INFO"
264 Warn -> "WARN"
265 Error -> "ERROR"
267compactCallStack :: CallStack -> String
268compactCallStack =
269 unwords
270 . List.intersperse "->"
271 . map (\(f, l) -> f <> " (" <> compactLoc l <> ")")
272 . getCallStack
273 where compactLoc loc = srcLocFile loc <> ":" <> show (srcLocStartLine loc)
275parseLogLevel :: Text -> Either String LogSeverity
276parseLogLevel t = case Text.strip t of
277 "debug" -> pure Debug
278 "info" -> pure Info
279 "warn" -> pure Warn
280 "error" -> pure Error
281 _ -> Left
282 "Unreadable log level. Possible values: debug, info, warn and error"
284renderLogLevel :: LogSeverity -> Text
285renderLogLevel = \case
286 Debug -> "debug"
287 Info -> "info"
288 Warn -> "warn"
289 Error -> "error"