464491e..master · typeable/control-logger

git.iko.soy/typeable/control-logger

on master help sign in

control-logger.cabal+52−49

since splitsnapshots

unifiedsplit

@@ -1,52 +1,55 @@

1−cabal-version: 2.4

1+cabal-version: 2.4

2−name: control-logger

2+name: control-logger

3−version: 0.1.0.0

3+version: 0.1.0.0

4−synopsis: Logger used by all projects

4+synopsis: Logger used by all projects

5−license-file: LICENSE

5+license-file: LICENSE

6−build-type: Simple

6+build-type: Simple

7−

8−flag katip

9− default: True

10− manual: False

11− description: Enable Katip support

13library

8library

14− hs-source-dirs: src

9+ hs-source-dirs: src

15− ghc-options: -Wall

10+ ghc-options: -Wall

11+

12+ if !impl(ghcjs)

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+

16 if !impl(ghcjs)

38 if !impl(ghcjs)

17− exposed-modules: Control.Logger

18− Control.Logger.Katip

19− Control.Logger.Katip.Utils

20− Control.Logger.Orphans

21− exposed-modules: Control.Logger.Internal

22− build-depends: base

39+ build-depends:

23− , aeson

40+ , katip >=0.8.8.0

24− , bytestring

25− , control-has

26− , control-has-katip

27− , deepseq

28− , exceptions

29− , fast-logger

30− , http-client

31− , lens

32− , monad-logger

33− , mtl

34− , shakespeare

35− , text

36− , time

37− , unordered-containers

38− if !impl(ghcjs) || !flag(katip)

39− build-depends: katip

40− , optparse-applicative

41+ , optparse-applicative

42+

41− default-language: Haskell2010

43+ default-language: Haskell2010

42− default-extensions: RankNTypes

44+ default-extensions:

45+ ConstraintKinds

43− DataKinds

46+ DataKinds

47+ DeriveGeneric

44− FlexibleContexts

48+ FlexibleContexts

45− FlexibleInstances

49+ FlexibleInstances

46− LambdaCase

50+ LambdaCase

47− OverloadedStrings

51+ OverloadedStrings

48− ScopedTypeVariables

52+ RankNTypes

49− DeriveGeneric

50− ConstraintKinds

51− RecordWildCards

53+ RecordWildCards

54+ ScopedTypeVariables

52− TypeSynonymInstances

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+69−15

@@ -1,7 +1,10 @@

1−

1+{-# LANGUAGE CPP #-}

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,20 +35,27 @@ 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

39−import Control.Logger.Orphans ()

46+import Control.Logger.Orphans ()

47+import Control.Monad

40import Control.Monad.Catch

48import Control.Monad.Catch

49+import Control.Monad.IO.Class

41−import qualified Data.List as List

50+import qualified Data.List as List

42−import Data.Text (Text)

51+import Data.Monoid

52+import Data.Text (Text)

43−import qualified Data.Text as Text

53+import qualified Data.Text as Text

44import Data.Time

54import Data.Time

45import GHC.Stack

55import GHC.Stack

46−import Katip (ToObject(..))

56+import Katip (ToObject (..))

47import System.Log.FastLogger

57import System.Log.FastLogger

48−import Text.Shakespeare.Text (st)

58+import Text.Shakespeare.Text (st)

50logError

60logError

51 :: (LoggingMonad r m)

61 :: (LoggingMonad r m)

@@ -76,28 +86,72 @@ logInfoWith

76 => Logger

86 => Logger

77 -> Text

87 -> Text

78 -> m ()

88 -> m ()

79−logInfoWith logger msg = withFrozenCallStack (logMsgWith logger mempty Info msg)

89+logInfoWith logger msg = withFrozenCallStack (logMsgWith logger Info msg)

81logDebugWith

91logDebugWith

82 :: (MonadIO m, HasCallStack)

92 :: (MonadIO m, HasCallStack)

83 => Logger

93 => Logger

84 -> Text

94 -> Text

85 -> m ()

95 -> m ()

86−logDebugWith logger msg = withFrozenCallStack (logMsgWith logger mempty Debug msg)

96+logDebugWith logger msg = withFrozenCallStack (logMsgWith logger Debug msg)

88logWarnWith

98logWarnWith

89 :: (MonadIO m, HasCallStack)

99 :: (MonadIO m, HasCallStack)

90 => Logger

100 => Logger

91 -> Text

101 -> Text

92 -> m ()

102 -> m ()

93−logWarnWith logger msg = withFrozenCallStack (logMsgWith logger mempty Warn msg)

103+logWarnWith logger msg = withFrozenCallStack (logMsgWith logger Warn msg)

104

95logErrorWith

105logErrorWith

96 :: (MonadIO m, HasCallStack)

106 :: (MonadIO m, HasCallStack)

97 => Logger

107 => Logger

98 -> Text

108 -> Text

99 -> m ()

109 -> m ()

100−logErrorWith logger msg = withFrozenCallStack (logMsgWith logger mempty Error msg)

110+logErrorWith logger msg = withFrozenCallStack (logMsgWith logger Error msg)

111+

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

127+withScrubber

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

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

130+ -> m a

131+ -> m a

132+withScrubber scrubF = local expandScrubber

133+ where

134+ expandScrubber :: r -> r

135+ expandScrubber = over part (over scrubber scrubF)

136+

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

138+censoringWith

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

140+ => Text

141+ -> Text

142+ -> m a

143+ -> m a

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

145+ where

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 "***"

101

155

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

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

103tryLogError

157tryLogError

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

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

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

150

204

151silentLogger :: Logger

205silentLogger :: Logger

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

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

153

207

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

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

155-- stderrLogger.

209-- stderrLogger.

156flushingFastFunc

210flushingFastFunc

157 :: LogSeverity -> LoggerSet -> Logger

211 :: LogSeverity -> LoggerSet -> Logger

158flushingFastFunc minLogLevel loggerSet =

212flushingFastFunc minLogLevel loggerSet =

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

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

160 when (logLevel >= minLogLevel) $ do

214 when (logLevel >= minLogLevel) $ do

161 ts <- getCurrentTime

215 ts <- getCurrentTime

162 pushLogStr loggerSet

216 pushLogStr loggerSet

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

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

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

181fastFunc :: LoggerSet -> Logger

235fastFunc :: LoggerSet -> Logger

182fastFunc loggerSet =

236fastFunc loggerSet =

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

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

184

238

185type LogSource = Text

239type LogSource = Text

186

240

187-- | Default logger tests and same things.

241-- | Default logger tests and same things.

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

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

189defaultFastFunc loc minLogLevel loggerSet =

243defaultFastFunc loc minLogLevel loggerSet =

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

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

191 ts <- getCurrentTime

245 ts <- getCurrentTime

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

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

193

247

src/Control/Logger/Internal.hs+33−13

@@ -1,9 +1,12 @@

1{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE NamedFieldPuns #-}

3+{-# LANGUAGE CPP #-}

3module Control.Logger.Internal

5module Control.Logger.Internal

4 ( Logger(..)

6 ( Logger(..)

5 , loggerContext

7 , loggerContext

6 , loggerAction

8 , loggerAction

9+ , scrubber

7 , runLogger

10 , runLogger

8 , LogSeverity(..)

11 , LogSeverity(..)

9 , LoggingMonad

12 , LoggingMonad

@@ -13,10 +16,11 @@ module Control.Logger.Internal

14import Control.Has

17import Control.Has

15import Control.Lens

18import Control.Lens

19+import Control.Monad.IO.Class

16import Control.DeepSeq

20import Control.DeepSeq

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

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

18import Data.Text (Text)

22import Data.Text (Text)

19−import GHC.Generics (Generic)

23+import Data.Monoid

20import GHC.Stack

24import GHC.Stack

@@ -30,23 +34,26 @@ data LogSeverity

30instance ToJSON LogSeverity

34instance ToJSON LogSeverity

31instance FromJSON LogSeverity

35instance FromJSON LogSeverity

33−data Logger

37+data Logger = Logger

34− = Logger

35 { _loggerContext :: Object

38 { _loggerContext :: Object

39+ , _scrubber :: Endo Text

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

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

37 } deriving Generic

41 } deriving Generic

39−instance NFData Logger

43+instance NFData Logger where

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

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

41makeLenses ''Logger

47makeLenses ''Logger

43instance Semigroup Logger where

49instance Semigroup Logger where

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

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

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

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

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

46 where ctx' = ctx1 <> ctx2

53 where ctx' = ctx1 <> ctx2

48instance Monoid Logger where

55instance Monoid Logger where

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

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

51type LoggingMonad r m =

58type LoggingMonad r m =

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

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

@@ -58,17 +65,30 @@ logMsg

58 -> m ()

65 -> m ()

59logMsg s t = withFrozenCallStack $ do

66logMsg s t = withFrozenCallStack $ do

60 logger <- view part

67 logger <- view part

61− logMsgWith logger mempty s t

68+ logMsgWith logger s t

63logMsgWith

70logMsgWith

64 :: (MonadIO m, HasCallStack)

71 :: (MonadIO m, HasCallStack)

65 => Logger

72 => Logger

66− -> Object

67 -> LogSeverity

73 -> LogSeverity

68 -> Text

74 -> Text

69 -> m ()

75 -> m ()

70−logMsgWith logger extra s t =

76+logMsgWith logger s t =

71− liftIO $ runLogger logger extra callStack s t

77+ liftIO $ runLogger logger callStack s t

73−runLogger :: Logger -> Object -> CallStack -> LogSeverity -> Text -> IO ()

79+runLogger :: Logger -> CallStack -> LogSeverity -> Text -> IO ()

74−runLogger (Logger ctx logger) extra = logger (ctx <> extra)

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

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

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

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

10import Control.Has

11import Control.Logger.Internal

12import Control.Monad.Logger

13−import qualified Data.Text as T

13+import qualified Data.Text.Encoding as T

14import GHC.Stack

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

21 in withFrozenCallStack

22 $ logMsg

23 (mlLevelToLogSeverity level)

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

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

26locToCallStack :: Loc -> CallStack

27locToCallStack Loc {..} = fromCallSiteList

stack.yamldeleted−14

@@ -1,14 +0,0 @@

1−resolver: lts-21.8

2−

3−packages:

4−- .

5−

6−extra-deps:

7− - git: https://github.com/typeable/control-has.git

8− commit: 017dd75cc5299dab13fc18812e7fe5ef6c1329ba

9−

10− - git: https://github.com/typeable/control-has-katip.git

11− commit: e9ac1b8d0fe17d8b3670d2fe344965756393ae09

12−

13−nix:

14− packages: [zlib]