5c2c6db...master · typeable/control-logger

git.iko.soy/typeable/control-logger

6 files changed+127−71

since splitsnapshots

unifiedsplit

control-logger.cabal+51−43 default.nix+9 src/Control/Logger.hs+38−14 src/Control/Logger/Internal.hs+26−11 src/Control/Logger/Katip.hs+1−1 src/Control/Logger/Orphans.hs+2−2

control-logger.cabal+51−43

@@ -1,47 +1,55 @@

1−cabal-version: 2.4

2−name: control-logger

3−version: 0.1.0.0

4−synopsis: Logger used by all projects

5−license-file: LICENSE

6−build-type: Simple

1+cabal-version: 2.4

2+name: control-logger

3+version: 0.1.0.0

4+synopsis: Logger used by all projects

5+license-file: LICENSE

6+build-type: Simple

88library

9− hs-source-dirs: src

10− ghc-options: -Wall

9+ hs-source-dirs: src

10+ ghc-options: -Wall

11+

1112 if !impl(ghcjs)

12− exposed-modules: Control.Logger

13− Control.Logger.Katip

14− Control.Logger.Katip.Utils

15− Control.Logger.Orphans

16− exposed-modules: Control.Logger.Internal

17− build-depends: base

18− , aeson

19− , bytestring

20− , control-has

21− , control-has-katip

22− , deepseq

23− , exceptions

24− , fast-logger

25− , http-client

26− , lens

27− , monad-logger

28− , mtl

29− , shakespeare

30− , text

31− , time

32− , unordered-containers

13+ exposed-modules:

14+ Control.Logger

15+ Control.Logger.Katip

16+ Control.Logger.Katip.Utils

17+ Control.Logger.Orphans

18+

19+ exposed-modules: Control.Logger.Internal

20+ build-depends:

21+ , aeson

22+ , base >=4.11

23+ , bytestring

24+ , control-has

25+ , control-has-katip

26+ , deepseq

27+ , exceptions

28+ , fast-logger >=2.4.11

29+ , http-client

30+ , lens

31+ , monad-logger

32+ , mtl

33+ , shakespeare

34+ , text

35+ , time

36+ , unordered-containers

37+

3338 if !impl(ghcjs)

34− build-depends: katip >= 0.8.8.0

35− , optparse-applicative

36− default-language: Haskell2010

37− default-extensions: RankNTypes

38− DataKinds

39− FlexibleContexts

40− FlexibleInstances

41− LambdaCase

42− OverloadedStrings

43− ScopedTypeVariables

44− DeriveGeneric

45− ConstraintKinds

46− RecordWildCards

47− TypeSynonymInstances

39+ build-depends:

40+ , katip >=0.8.8.0

41+ , optparse-applicative

42+

43+ default-language: Haskell2010

44+ default-extensions:

45+ ConstraintKinds

46+ DataKinds

47+ DeriveGeneric

48+ FlexibleContexts

49+ FlexibleInstances

50+ LambdaCase

51+ OverloadedStrings

52+ RankNTypes

53+ RecordWildCards

54+ ScopedTypeVariables

55+ TypeSynonymInstances

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+38−14

@@ -3,6 +3,8 @@ module Control.Logger

33 ( Logger

44 , loggerContext

55 , scrubber

6+ , censor

7+ , censorWith

68 , logMsg

79 , logMsgWith

810 , logInfo

@@ -34,6 +36,7 @@ module Control.Logger

3436 , st

3537 , ToObject(..)

3638 , withScrubber

39+ , censoringWith

3740 , censoring

3841 ) where

3942

@@ -41,7 +44,9 @@ import Control.Has

4144import Control.Lens hiding (censoring)

4245import Control.Logger.Internal

4346import Control.Logger.Orphans ()

47+import Control.Monad

4448import Control.Monad.Catch

49+import Control.Monad.IO.Class

4550import qualified Data.List as List

4651import Data.Monoid

4752import Data.Text (Text)

@@ -51,10 +56,6 @@ import GHC.Stack

5156import Katip (ToObject (..))

5257import System.Log.FastLogger

5358import Text.Shakespeare.Text (st)

54−#if MIN_VERSION_mtl(2,3,0)

55−import Control.Monad

56−import Control.Monad.IO.Class

57−#endif

5859

5960logError

6061 :: (LoggingMonad r m)

@@ -108,26 +109,49 @@ logErrorWith

108109 -> m ()

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

110111

111−-- | Adjust the scrubbing function.

112+safeReplace :: Text -> Text -> Text -> Text

113+safeReplace what with where_

114+ | Text.null what = where_

115+ | otherwise = Text.replace what with where_

116+

117+-- | Add a some text to scrubber

118+censorWith :: Text -> Text -> Logger -> Logger

119+censorWith replacement needle l =

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

121+

122+-- | Censor with "***"

123+censor :: Text -> Logger -> Logger

124+censor = censorWith "***"

125+

126+-- | Run an action with adjusted scrubber

112127withScrubber

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

114− => Endo (Text -> Text)

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

115130 -> m a

116131 -> m a

117132withScrubber scrubF = local expandScrubber

118133 where

119134 expandScrubber :: r -> r

120− expandScrubber = over part (over scrubber (appEndo scrubF))

135+ expandScrubber = over part (over scrubber scrubF)

121136

122137-- | Run an action while censoring additional text from logs

123−censoring

138+censoringWith

124139 :: (Has Logger r, MonadReader r m)

125140 => Text

141+ -> Text

126142 -> m a

127143 -> m a

128−censoring txt = withScrubber (Endo (. censored))

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

129145 where

130− censored = Text.replace txt "XXXX"

146+ censored = Endo (safeReplace txt replacement)

147+

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

149+censoring

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

151+ => Text

152+ -> m a

153+ -> m a

154+censoring = censoringWith "***"

131155

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

133157tryLogError

@@ -179,14 +203,14 @@ fileLogger :: MonadIO m => FilePath -> m Logger

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

180204

181205silentLogger :: Logger

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

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

183207

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

185209-- stderrLogger.

186210flushingFastFunc

187211 :: LogSeverity -> LoggerSet -> Logger

188212flushingFastFunc minLogLevel loggerSet =

189− Logger mempty id $ \_ stack logLevel msg ->

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

190214 when (logLevel >= minLogLevel) $ do

191215 ts <- getCurrentTime

192216 pushLogStr loggerSet

@@ -210,14 +234,14 @@ flushingStderrLogger =

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

211235fastFunc :: LoggerSet -> Logger

212236fastFunc loggerSet =

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

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

214238

215239type LogSource = Text

216240

217241-- | Default logger tests and same things.

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

219243defaultFastFunc loc minLogLevel loggerSet =

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

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

221245 ts <- getCurrentTime

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

223247

src/Control/Logger/Internal.hs+26−11

@@ -1,4 +1,5 @@

11{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE NamedFieldPuns #-}

23{-# LANGUAGE CPP #-}

45module Control.Logger.Internal

@@ -15,13 +16,12 @@ module Control.Logger.Internal

1516

1617import Control.Has

1718import Control.Lens

19+import Control.Monad.IO.Class

1820import Control.DeepSeq

19−import Data.Aeson (ToJSON, FromJSON, Object)

21+import Data.Aeson (ToJSON, FromJSON, Object, Value(..))

2022import Data.Text (Text)

23+import Data.Monoid

2124import GHC.Stack

22−#if MIN_VERSION_mtl(2,3,0)

23−import Control.Monad.IO.Class

24−#endif

2525

2626

2727data LogSeverity

@@ -34,25 +34,26 @@ data LogSeverity

3434instance ToJSON LogSeverity

3535instance FromJSON LogSeverity

3636

37−data Logger

38− = Logger

37+data Logger = Logger

3938 { _loggerContext :: Object

40− , _scrubber :: Text -> Text

39+ , _scrubber :: Endo Text

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

4241 } deriving Generic

4342

44−instance NFData Logger

43+instance NFData Logger where

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

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

4546

4647makeLenses ''Logger

4748

4849instance Semigroup Logger where

4950 (Logger ctx1 s1 l1) <> (Logger ctx2 s2 l2)

50− = Logger ctx' (s1 . s2)

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

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

5253 where ctx' = ctx1 <> ctx2

5354

5455instance Monoid Logger where

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

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

5657

5758type LoggingMonad r m =

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

@@ -76,4 +77,18 @@ logMsgWith logger s t =

7677 liftIO $ runLogger logger callStack s t

7778

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

79−runLogger (Logger ctx scrubber logger) cs ls txt = logger ctx cs ls (scrubber txt)

80+runLogger (Logger ctx theScrubber logger) cs ls txt

81+ = logger (scrubContext theScrubber ctx) cs ls (appEndo theScrubber txt)

82+

83+

84+scrubContext :: Endo Text -> Object -> Object

85+scrubContext theScrubber = fmap doScrub

86+ where

87+ doScrub :: Value -> Value

88+ doScrub = \case

89+ Object object -> Object (fmap doScrub object)

90+ Array array -> Array (fmap doScrub array)

91+ String string -> String (appEndo theScrubber string)

92+ n@Number{} -> n

93+ b@Bool{} -> b

94+ n@Null -> n

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) id

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

6060 $ \ ctx stack s msg ->

6161 let ?callStack = stack

6262 in

src/Control/Logger/Orphans.hs+2−2

@@ -10,7 +10,7 @@ import Control.EnvT

1010import Control.Has

1111import Control.Logger.Internal

1212import Control.Monad.Logger

13−import qualified Data.Text as T

13+import qualified Data.Text.Encoding as T

1414import GHC.Stack

1515

1616

@@ -21,7 +21,7 @@ instance (Has Logger r, MonadIO m)

2121 in withFrozenCallStack

2222 $ logMsg

2323 (mlLevelToLogSeverity level)

24− (T.pack . show . toLogStr $ msg)

24+ (T.decodeUtf8Lenient . fromLogStr . toLogStr $ msg)

2525

2626locToCallStack :: Loc -> CallStack

2727locToCallStack Loc {..} = fromCallSiteList