4e31de2 · typeable/control-logger

git.iko.soy/typeable/control-logger

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

commit4e31de2624439b72ffda8bd4207eba6d9f63e08a authorVille Tirronen <ville@typeable.io> dateWed 24 Apr 2024, 10:34 (2 years ago) parenta2e5938 16c79c4

6 files changed+82−15

compare with master

unifiedsplit

control-logger.cabal+1−1 default.nix+9 src/Control/Logger.hs+57−4 src/Control/Logger/Internal.hs+12−6 src/Control/Logger/Katip.hs+1−1 src/Control/Logger/Katip/Utils.hs+2−3

control-logger.cabal+1−1

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

3131 , time

3232 , unordered-containers

3333 if !impl(ghcjs)

34− build-depends: katip

34+ build-depends: katip >= 0.8.8.0

3535 , optparse-applicative

3636 default-language: Haskell2010

3737 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 @@

22module Control.Logger

33 ( Logger

44 , loggerContext

5+ , scrubber

6+ , censor

7+ , censorWith

58 , logMsg

69 , logMsgWith

710 , logInfo

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

3235 , compactCallStack

3336 , st

3437 , ToObject(..)

38+ , withScrubber

39+ , censoringWith

40+ , censoring

3541 ) where

3642

3743import Control.Has

44+import Control.Lens hiding (censoring)

3845import Control.Logger.Internal

3946import Control.Logger.Orphans ()

4047import Control.Monad.Catch

4148import qualified Data.List as List

49+import Data.Monoid

4250import Data.Text (Text)

4351import qualified Data.Text as Text

4452import Data.Time

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

4654import Katip (ToObject (..))

4755import System.Log.FastLogger

4856import Text.Shakespeare.Text (st)

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

4958#if MIN_VERSION_mtl(2,3,0)

5059import Control.Monad

5160import Control.Monad.IO.Class

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

103112 -> m ()

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

105114

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+

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

107160tryLogError

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

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

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

154207

155208silentLogger :: Logger

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

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

157210

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

159212-- stderrLogger.

160213flushingFastFunc

161214 :: LogSeverity -> LoggerSet -> Logger

162215flushingFastFunc minLogLevel loggerSet =

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

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

164217 when (logLevel >= minLogLevel) $ do

165218 ts <- getCurrentTime

166219 pushLogStr loggerSet

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

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

185238fastFunc :: LoggerSet -> Logger

186239fastFunc loggerSet =

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

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

188241

189242type LogSource = Text

190243

191244-- | Default logger tests and same things.

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

193246defaultFastFunc loc minLogLevel loggerSet =

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

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

195248 ts <- getCurrentTime

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

197250

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

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

11{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE NamedFieldPuns #-}

23{-# LANGUAGE CPP #-}

45module Control.Logger.Internal

56 ( Logger(..)

67 , loggerContext

78 , loggerAction

9+ , scrubber

810 , runLogger

911 , LogSeverity(..)

1012 , LoggingMonad

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

1719import Control.DeepSeq

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

1921import Data.Text (Text)

22+import Data.Monoid

2023import GHC.Stack

2124#if MIN_VERSION_mtl(2,3,0)

2225import Control.Monad.IO.Class

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

3336instance ToJSON LogSeverity

3437instance FromJSON LogSeverity

3538

36−data Logger

37− = Logger

39+data Logger = Logger

3840 { _loggerContext :: Object

41+ , _scrubber :: Endo Text

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

4043 } deriving Generic

4144

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

4348

4449makeLenses ''Logger

4550

4651instance 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)

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

4955 where ctx' = ctx1 <> ctx2

5056

5157instance Monoid Logger where

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

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

5359

5460type LoggingMonad r m =

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

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

7379 liftIO $ runLogger logger callStack s t

7480

7581runLogger :: 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

5656 payloadKeys _ _ = AllKeys

5757

5858getKatipLogger :: KatipContextTState -> Logger

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

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

6060 $ \ ctx stack s msg ->

6161 let ?callStack = stack

6262 in

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

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

1−{-# LANGUAGE ImplicitParams #-}

21{-# LANGUAGE CPP #-}

43module Control.Logger.Katip.Utils

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

121120 -> ReaderT r m a

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

123122 where

124− go (Logger ctx f) =

125− Logger (ctx <> ctx') f

123+ go (Logger ctx scrbber f) =

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