4e31de2 · typeable/control-logger

git.iko.soy/typeable/control-logger

on master help sign in

Merge pull request #4 from typeable/ville/log-censoring

4e31de2Ville Tirronen2 years ago

control-logger.cabal+1−1

compare with master

unifiedsplit

@@ -31,7 +31,7 @@ library

31 , time

32 , unordered-containers

33 if !impl(ghcjs)

34− build-depends: katip

34+ build-depends: katip >= 0.8.8.0

35 , optparse-applicative

36 default-language: Haskell2010

37 default-extensions: RankNTypes

default.nixnew file+9

@@ -0,0 +1,9 @@

1+{ pkgs ? import <nixpkgs> {} }:

3+pkgs.mkShell {

4+ buildInputs = [

5+ pkgs.ghc

6+ pkgs.haskellPackages.cabal-install

7+ pkgs.zlib

8+ ];

9+}

src/Control/Logger.hs+57−4

@@ -2,6 +2,9 @@

2module Control.Logger

3 ( Logger

4 , loggerContext

5+ , scrubber

6+ , censor

7+ , censorWith

5 , logMsg

8 , logMsg

6 , logMsgWith

9 , logMsgWith

7 , logInfo

10 , logInfo

@@ -32,13 +35,18 @@ module Control.Logger

32 , compactCallStack

35 , compactCallStack

33 , st

36 , st

34 , ToObject(..)

37 , ToObject(..)

38+ , withScrubber

39+ , censoringWith

40+ , censoring

35 ) where

41 ) where

37import Control.Has

43import Control.Has

44+import Control.Lens hiding (censoring)

38import Control.Logger.Internal

45import Control.Logger.Internal

39import Control.Logger.Orphans ()

46import Control.Logger.Orphans ()

40import Control.Monad.Catch

47import Control.Monad.Catch

41import qualified Data.List as List

48import qualified Data.List as List

49+import Data.Monoid

42import Data.Text (Text)

50import Data.Text (Text)

43import qualified Data.Text as Text

51import qualified Data.Text as Text

44import Data.Time

52import Data.Time

@@ -46,6 +54,7 @@ import GHC.Stack

46import Katip (ToObject (..))

54import Katip (ToObject (..))

47import System.Log.FastLogger

55import System.Log.FastLogger

48import Text.Shakespeare.Text (st)

56import Text.Shakespeare.Text (st)

57+-- import Control.Monad.RWS (censor)

49#if MIN_VERSION_mtl(2,3,0)

58#if MIN_VERSION_mtl(2,3,0)

50import Control.Monad

59import Control.Monad

51import Control.Monad.IO.Class

60import Control.Monad.IO.Class

@@ -103,6 +112,50 @@ logErrorWith

103 -> m ()

112 -> m ()

104logErrorWith logger msg = withFrozenCallStack (logMsgWith logger Error msg)

113logErrorWith logger msg = withFrozenCallStack (logMsgWith logger Error msg)

105

114

115+safeReplace :: Text -> Text -> Text -> Text

116+safeReplace what with where_

117+ | Text.null what = where_

118+ | otherwise = Text.replace what with where_

119+

120+-- | Add a some text to scrubber

121+censorWith :: Text -> Text -> Logger -> Logger

122+censorWith replacement needle l =

123+ l & scrubber <>~ Endo (safeReplace needle replacement)

124+

125+-- | Censor with "***"

126+censor :: Text -> Logger -> Logger

127+censor = censorWith "***"

128+

129+-- | Run an action with adjusted scrubber

130+withScrubber

131+ :: forall r m a. (Has Logger r, MonadReader r m)

132+ => (Endo Text -> Endo Text)

133+ -> m a

134+ -> m a

135+withScrubber scrubF = local expandScrubber

136+ where

137+ expandScrubber :: r -> r

138+ expandScrubber = over part (over scrubber scrubF)

139+

140+-- | Run an action while censoring additional text from logs

141+censoringWith

142+ :: (Has Logger r, MonadReader r m)

143+ => Text

144+ -> Text

145+ -> m a

146+ -> m a

147+censoringWith replacement txt = withScrubber (<> censored)

148+ where

149+ censored = Endo (safeReplace txt replacement)

150+

151+-- | Run an action while censoring additional text from logs

152+censoring

153+ :: (Has Logger r, MonadReader r m)

154+ => Text

155+ -> m a

156+ -> m a

157+censoring = censoringWith "***"

158+

106-- | Log exceptions occured in computation and just ignore them.

159-- | Log exceptions occured in computation and just ignore them.

107tryLogError

160tryLogError

108 :: (MonadIO m, MonadCatch m, Has Logger r, MonadReader r m)

161 :: (MonadIO m, MonadCatch m, Has Logger r, MonadReader r m)

@@ -153,14 +206,14 @@ fileLogger :: MonadIO m => FilePath -> m Logger

153fileLogger fp = fastFunc <$> liftIO (newFileLoggerSet defaultBufSize fp)

206fileLogger fp = fastFunc <$> liftIO (newFileLoggerSet defaultBufSize fp)

154

207

155silentLogger :: Logger

208silentLogger :: Logger

156−silentLogger = Logger mempty (\_ _ _ _ -> return ())

209+silentLogger = Logger mempty mempty (\_ _ _ _ -> return ())

157

210

158-- | Logger which flushes buffer after each message. This is useful with

211-- | Logger which flushes buffer after each message. This is useful with

159-- stderrLogger.

212-- stderrLogger.

160flushingFastFunc

213flushingFastFunc

161 :: LogSeverity -> LoggerSet -> Logger

214 :: LogSeverity -> LoggerSet -> Logger

162flushingFastFunc minLogLevel loggerSet =

215flushingFastFunc minLogLevel loggerSet =

163− Logger mempty $ \_ stack logLevel msg ->

216+ Logger mempty mempty $ \_ stack logLevel msg ->

164 when (logLevel >= minLogLevel) $ do

217 when (logLevel >= minLogLevel) $ do

165 ts <- getCurrentTime

218 ts <- getCurrentTime

166 pushLogStr loggerSet

219 pushLogStr loggerSet

@@ -184,14 +237,14 @@ flushingStderrLogger =

184-- | Make our outdated 'Logger' of fast-logger's 'LoggerSet'

237-- | Make our outdated 'Logger' of fast-logger's 'LoggerSet'

185fastFunc :: LoggerSet -> Logger

238fastFunc :: LoggerSet -> Logger

186fastFunc loggerSet =

239fastFunc loggerSet =

187− Logger mempty $ \_ _ _ msg -> pushLogStr loggerSet $ toLogStr msg

240+ Logger mempty mempty $ \_ _ _ msg -> pushLogStr loggerSet $ toLogStr msg

188

241

189type LogSource = Text

242type LogSource = Text

190

243

191-- | Default logger tests and same things.

244-- | Default logger tests and same things.

192defaultFastFunc :: LogSource -> LogSeverity -> LoggerSet -> Logger

245defaultFastFunc :: LogSource -> LogSeverity -> LoggerSet -> Logger

193defaultFastFunc loc minLogLevel loggerSet =

246defaultFastFunc loc minLogLevel loggerSet =

194− Logger mempty $ \_ stack s msg -> when (s >= minLogLevel) $ do

247+ Logger mempty mempty $ \_ stack s msg -> when (s >= minLogLevel) $ do

195 ts <- getCurrentTime

248 ts <- getCurrentTime

196 pushLogStr loggerSet $ formatLogStr ts stack loc s (toLogStr msg)

249 pushLogStr loggerSet $ formatLogStr ts stack loc s (toLogStr msg)

197

250

src/Control/Logger/Internal.hs+12−6

@@ -1,10 +1,12 @@

1{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE NamedFieldPuns #-}

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE CPP #-}

4module Control.Logger.Internal

5module Control.Logger.Internal

5 ( Logger(..)

6 ( Logger(..)

6 , loggerContext

7 , loggerContext

7 , loggerAction

8 , loggerAction

9+ , scrubber

8 , runLogger

10 , runLogger

9 , LogSeverity(..)

11 , LogSeverity(..)

10 , LoggingMonad

12 , LoggingMonad

@@ -17,6 +19,7 @@ import Control.Lens

17import Control.DeepSeq

19import Control.DeepSeq

18import Data.Aeson (ToJSON, FromJSON, Object)

20import Data.Aeson (ToJSON, FromJSON, Object)

19import Data.Text (Text)

21import Data.Text (Text)

22+import Data.Monoid

20import GHC.Stack

23import GHC.Stack

21#if MIN_VERSION_mtl(2,3,0)

24#if MIN_VERSION_mtl(2,3,0)

22import Control.Monad.IO.Class

25import Control.Monad.IO.Class

@@ -33,23 +36,26 @@ data LogSeverity

33instance ToJSON LogSeverity

36instance ToJSON LogSeverity

34instance FromJSON LogSeverity

37instance FromJSON LogSeverity

36−data Logger

39+data Logger = Logger

37− = Logger

38 { _loggerContext :: Object

40 { _loggerContext :: Object

41+ , _scrubber :: Endo Text

39 , _loggerAction :: Object -> CallStack -> LogSeverity -> Text -> IO ()

42 , _loggerAction :: Object -> CallStack -> LogSeverity -> Text -> IO ()

40 } deriving Generic

43 } deriving Generic

42−instance NFData Logger

45+instance NFData Logger where

46+ rnf Logger{_loggerContext, _scrubber, _loggerAction} =

47+ rnf _loggerContext `deepseq` rwhnf (appEndo _scrubber) `deepseq` rwhnf _loggerAction

44makeLenses ''Logger

49makeLenses ''Logger

46instance Semigroup Logger where

51instance Semigroup Logger where

47− (Logger ctx1 l1) <> (Logger ctx2 l2) = Logger ctx'

52+ (Logger ctx1 s1 l1) <> (Logger ctx2 s2 l2)

53+ = Logger ctx' (s1 <> s2)

48 $ \ctx stack s t -> l1 ctx stack s t >> l2 ctx stack s t

54 $ \ctx stack s t -> l1 ctx stack s t >> l2 ctx stack s t

49 where ctx' = ctx1 <> ctx2

55 where ctx' = ctx1 <> ctx2

51instance Monoid Logger where

57instance Monoid Logger where

52− mempty = Logger mempty $ \_ _ _ _ -> pure ()

58+ mempty = Logger mempty mempty $ \_ _ _ _ -> pure ()

54type LoggingMonad r m =

60type LoggingMonad r m =

55 (MonadReader r m, Has Logger r, MonadIO m, HasCallStack)

61 (MonadReader r m, Has Logger r, MonadIO m, HasCallStack)

@@ -73,4 +79,4 @@ logMsgWith logger s t =

73 liftIO $ runLogger logger callStack s t

79 liftIO $ runLogger logger callStack s t

75runLogger :: Logger -> CallStack -> LogSeverity -> Text -> IO ()

81runLogger :: Logger -> CallStack -> LogSeverity -> Text -> IO ()

76−runLogger (Logger ctx logger) = logger ctx

82+runLogger (Logger ctx theScrubber logger) cs ls txt = logger ctx cs ls (appEndo theScrubber txt)

src/Control/Logger/Katip.hs+1−1

@@ -56,7 +56,7 @@ instance LogItem Object where

56 payloadKeys _ _ = AllKeys

58getKatipLogger :: KatipContextTState -> Logger

59−getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx)

59+getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx) mempty

60 $ \ ctx stack s msg ->

61 let ?callStack = stack

62 in

src/Control/Logger/Katip/Utils.hs+2−3

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ImplicitParams #-}

2{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

4module Control.Logger.Katip.Utils

3module Control.Logger.Katip.Utils

@@ -121,5 +120,5 @@ setLoggingCtx

121 -> ReaderT r m a

120 -> ReaderT r m a

122setLoggingCtx ctx' = local (part %~ go)

121setLoggingCtx ctx' = local (part %~ go)

123 where

122 where

124− go (Logger ctx f) =

123+ go (Logger ctx scrbber f) =

125− Logger (ctx <> ctx') f

124+ Logger (ctx <> ctx') scrbber f