master..c83d792 · typeable/control-logger

git.iko.soy/typeable/control-logger

on c83d792 help sign in

control-logger.cabal+49−52

since splitsnapshots

unifiedsplit

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

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

8−library

9− hs-source-dirs: src

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

8+flag katip

26− , deepseq

9+ default: True

27− , exceptions

10+ manual: False

28− , fast-logger >=2.4.11

11+ description: Enable Katip support

29− , http-client

30− , lens

31− , monad-logger

32− , mtl

33− , shakespeare

34− , text

35− , time

36− , unordered-containers

13+library

14+ hs-source-dirs: src

15+ ghc-options: -Wall

38 if !impl(ghcjs)

16 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

39− build-depends:

22+ build-depends: base

23+ , aeson

24+ , bytestring

25+ , control-has

40− , katip >=0.8.8.0

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

41− , optparse-applicative

40+ , optparse-applicative

42−

43− default-language: Haskell2010

41+ default-language: Haskell2010

44− default-extensions:

42+ default-extensions: RankNTypes

45− ConstraintKinds

46− DataKinds

43+ DataKinds

47− DeriveGeneric

48− FlexibleContexts

44+ FlexibleContexts

49− FlexibleInstances

45+ FlexibleInstances

50− LambdaCase

46+ LambdaCase

51− OverloadedStrings

47+ OverloadedStrings

52− RankNTypes

48+ ScopedTypeVariables

49+ DeriveGeneric

50+ ConstraintKinds

53− RecordWildCards

51+ RecordWildCards

54− ScopedTypeVariables

55− TypeSynonymInstances

52+ 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+11−65

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

1−{-# LANGUAGE CPP #-}

2module Control.Logger

3 ( Logger

4 , loggerContext

5− , scrubber

6− , censor

7− , censorWith

8 , logMsg

5 , logMsg

9 , logMsgWith

6 , logMsgWith

10 , logInfo

7 , logInfo

@@ -35,27 +32,20 @@ module Control.Logger

35 , compactCallStack

32 , compactCallStack

36 , st

33 , st

37 , ToObject(..)

34 , ToObject(..)

38− , withScrubber

39− , censoringWith

40− , censoring

41 ) where

35 ) where

43import Control.Has

37import Control.Has

44−import Control.Lens hiding (censoring)

45import Control.Logger.Internal

38import Control.Logger.Internal

46−import Control.Logger.Orphans ()

39+import Control.Logger.Orphans ()

47−import Control.Monad

48import Control.Monad.Catch

40import Control.Monad.Catch

49−import Control.Monad.IO.Class

50−import qualified Data.List as List

41+import qualified Data.List as List

51−import Data.Monoid

52−import Data.Text (Text)

42+import Data.Text (Text)

53−import qualified Data.Text as Text

43+import qualified Data.Text as Text

54import Data.Time

44import Data.Time

55import GHC.Stack

45import GHC.Stack

56−import Katip (ToObject (..))

46+import Katip (ToObject(..))

57import System.Log.FastLogger

47import System.Log.FastLogger

58−import Text.Shakespeare.Text (st)

48+import Text.Shakespeare.Text (st)

60logError

50logError

61 :: (LoggingMonad r m)

51 :: (LoggingMonad r m)

@@ -109,50 +99,6 @@ logErrorWith

109 -> m ()

99 -> m ()

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

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

111

101

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

155−

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

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

157tryLogError

103tryLogError

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

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

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

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

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

204

150

205silentLogger :: Logger

151silentLogger :: Logger

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

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

207

153

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

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

209-- stderrLogger.

155-- stderrLogger.

210flushingFastFunc

156flushingFastFunc

211 :: LogSeverity -> LoggerSet -> Logger

157 :: LogSeverity -> LoggerSet -> Logger

212flushingFastFunc minLogLevel loggerSet =

158flushingFastFunc minLogLevel loggerSet =

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

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

214 when (logLevel >= minLogLevel) $ do

160 when (logLevel >= minLogLevel) $ do

215 ts <- getCurrentTime

161 ts <- getCurrentTime

216 pushLogStr loggerSet

162 pushLogStr loggerSet

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

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

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

235fastFunc :: LoggerSet -> Logger

181fastFunc :: LoggerSet -> Logger

236fastFunc loggerSet =

182fastFunc loggerSet =

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

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

238

184

239type LogSource = Text

185type LogSource = Text

240

186

241-- | Default logger tests and same things.

187-- | Default logger tests and same things.

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

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

243defaultFastFunc loc minLogLevel loggerSet =

189defaultFastFunc loc minLogLevel loggerSet =

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

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

245 ts <- getCurrentTime

191 ts <- getCurrentTime

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

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

247

193

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

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

1{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE NamedFieldPuns #-}

3−{-# LANGUAGE CPP #-}

5module Control.Logger.Internal

3module Control.Logger.Internal

6 ( Logger(..)

4 ( Logger(..)

7 , loggerContext

5 , loggerContext

8 , loggerAction

6 , loggerAction

9− , scrubber

10 , runLogger

7 , runLogger

11 , LogSeverity(..)

8 , LogSeverity(..)

12 , LoggingMonad

9 , LoggingMonad

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

17import Control.Has

14import Control.Has

18import Control.Lens

15import Control.Lens

19−import Control.Monad.IO.Class

20import Control.DeepSeq

16import Control.DeepSeq

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

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

22import Data.Text (Text)

18import Data.Text (Text)

23−import Data.Monoid

19+import GHC.Generics (Generic)

24import GHC.Stack

20import GHC.Stack

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

34instance ToJSON LogSeverity

30instance ToJSON LogSeverity

35instance FromJSON LogSeverity

31instance FromJSON LogSeverity

37−data Logger = Logger

33+data Logger

34+ = Logger

38 { _loggerContext :: Object

35 { _loggerContext :: Object

39− , _scrubber :: Endo Text

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

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

41 } deriving Generic

37 } deriving Generic

43−instance NFData Logger where

39+instance NFData Logger

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

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

47makeLenses ''Logger

41makeLenses ''Logger

49instance Semigroup Logger where

43instance Semigroup Logger where

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

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

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

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

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

53 where ctx' = ctx1 <> ctx2

46 where ctx' = ctx1 <> ctx2

55instance Monoid Logger where

48instance Monoid Logger where

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

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

58type LoggingMonad r m =

51type LoggingMonad r m =

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

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

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

65 -> m ()

58 -> m ()

66logMsg s t = withFrozenCallStack $ do

59logMsg s t = withFrozenCallStack $ do

67 logger <- view part

60 logger <- view part

68− logMsgWith logger s t

61+ logMsgWith logger mempty s t

70logMsgWith

63logMsgWith

71 :: (MonadIO m, HasCallStack)

64 :: (MonadIO m, HasCallStack)

72 => Logger

65 => Logger

66+ -> Object

73 -> LogSeverity

67 -> LogSeverity

74 -> Text

68 -> Text

75 -> m ()

69 -> m ()

76−logMsgWith logger s t =

70+logMsgWith logger extra s t =

77− liftIO $ runLogger logger callStack s t

71+ liftIO $ runLogger logger extra callStack s t

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

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

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

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

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

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

60 $ \ ctx stack s msg ->

61 let ?callStack = stack

62 in

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

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

1+{-# LANGUAGE ImplicitParams #-}

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE CPP #-}

3module Control.Logger.Katip.Utils

4module Control.Logger.Katip.Utils

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

120 -> ReaderT r m a

121 -> ReaderT r m a

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

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

122 where

123 where

123− go (Logger ctx scrbber f) =

124+ go (Logger ctx f) =

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

125+ Logger (ctx <> ctx') 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.Encoding as T

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

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

26locToCallStack :: Loc -> CallStack

27locToCallStack Loc {..} = fromCallSiteList

stack.yamlnew file+14

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

1+resolver: lts-21.8

3+packages:

4+- .

6+extra-deps:

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

8+ commit: 017dd75cc5299dab13fc18812e7fe5ef6c1329ba

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

11+ commit: e9ac1b8d0fe17d8b3670d2fe344965756393ae09

12+

13+nix:

14+ packages: [zlib]