master..5c2c6db · typeable/control-logger

git.iko.soy/typeable/control-logger

6 files changed+71−127

unifiedsplit

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

control-logger.cabal+43−51

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

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

11−

9+ hs-source-dirs: src

10+ ghc-options: -Wall

1211 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−

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

3833 if !impl(ghcjs)

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

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

default.nixdeleted−9

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

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

2−

3−pkgs.mkShell {

4− buildInputs = [

5− pkgs.ghc

6− pkgs.haskellPackages.cabal-install

7− pkgs.zlib

8− ];

9−}

src/Control/Logger.hs+14−38

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

33 ( Logger

44 , loggerContext

55 , scrubber

6− , censor

7− , censorWith

86 , logMsg

97 , logMsgWith

108 , logInfo

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

3634 , st

3735 , ToObject(..)

3836 , withScrubber

39− , censoringWith

4037 , censoring

4138 ) where

4239

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

4441import Control.Lens hiding (censoring)

4542import Control.Logger.Internal

4643import Control.Logger.Orphans ()

47−import Control.Monad

4844import Control.Monad.Catch

49−import Control.Monad.IO.Class

5045import qualified Data.List as List

5146import Data.Monoid

5247import Data.Text (Text)

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

5651import Katip (ToObject (..))

5752import System.Log.FastLogger

5853import Text.Shakespeare.Text (st)

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

55+import Control.Monad

56+import Control.Monad.IO.Class

57+#endif

5958

6059logError

6160 :: (LoggingMonad r m)

@@ -109,41 +108,16 @@ logErrorWith

109108 -> m ()

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

111110

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

111+-- | Adjust the scrubbing function.

127112withScrubber

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

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

114+ => Endo (Text -> Text)

130115 -> m a

131116 -> m a

132117withScrubber scrubF = local expandScrubber

133118 where

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

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

147121

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

149123censoring

@@ -151,7 +125,9 @@ censoring

151125 => Text

152126 -> m a

153127 -> m a

154−censoring = censoringWith "***"

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

129+ where

130+ censored = Text.replace txt "XXXX"

155131

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

157133tryLogError

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

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

204180

205181silentLogger :: Logger

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

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

207183

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

209185-- stderrLogger.

210186flushingFastFunc

211187 :: LogSeverity -> LoggerSet -> Logger

212188flushingFastFunc minLogLevel loggerSet =

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

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

214190 when (logLevel >= minLogLevel) $ do

215191 ts <- getCurrentTime

216192 pushLogStr loggerSet

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

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

235211fastFunc :: LoggerSet -> Logger

236212fastFunc loggerSet =

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

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

238214

239215type LogSource = Text

240216

241217-- | Default logger tests and same things.

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

243219defaultFastFunc loc minLogLevel loggerSet =

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

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

245221 ts <- getCurrentTime

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

247223

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

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

11{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE NamedFieldPuns #-}

32{-# LANGUAGE CPP #-}

54module Control.Logger.Internal

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

1615

1716import Control.Has

1817import Control.Lens

19−import Control.Monad.IO.Class

2018import Control.DeepSeq

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

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

2220import Data.Text (Text)

23−import Data.Monoid

2421import GHC.Stack

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

23+import Control.Monad.IO.Class

24+#endif

2525

2626

2727data LogSeverity

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

3434instance ToJSON LogSeverity

3535instance FromJSON LogSeverity

3636

37−data Logger = Logger

37+data Logger

38+ = Logger

3839 { _loggerContext :: Object

39− , _scrubber :: Endo Text

40+ , _scrubber :: Text -> Text

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

4142 } deriving Generic

4243

43−instance NFData Logger where

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

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

44+instance NFData Logger

4645

4746makeLenses ''Logger

4847

4948instance Semigroup Logger where

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

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

50+ = Logger ctx' (s1 . s2)

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

5352 where ctx' = ctx1 <> ctx2

5453

5554instance Monoid Logger where

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

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

5756

5857type LoggingMonad r m =

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

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

7776 liftIO $ runLogger logger callStack s t

7877

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

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

79+runLogger (Logger ctx scrubber logger) cs ls txt = logger ctx cs ls (scrubber 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) mempty

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

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.Encoding as T

13+import qualified Data.Text 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.decodeUtf8Lenient . fromLogStr . toLogStr $ msg)

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

2525

2626locToCallStack :: Loc -> CallStack

2727locToCallStack Loc {..} = fromCallSiteList