db6986a...master · typeable/control-logger

.gitignorenew file+3

@@ -0,0 +1,3 @@

1+.stack-work

2+*~

3+*.swp

README.md+1−1

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

11# control-logger

22

3−Utilities for logging with DTT projects

3+Utilities for logging

control-logger.cabal+51−45

@@ -1,49 +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

77

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.Scribes.Reopenable

15− Control.Logger.Katip.Utils

16− Control.Logger.Orphans

17− exposed-modules: Control.Logger.Internal

18− build-depends: base

19− , aeson

20− , bytestring

21− , control-has

22− , control-has-katip

23− , deepseq

24− , exceptions

25− , fast-logger

26− , http-client

27− , lens

28− , monad-logger

29− , mtl

30− , shakespeare

31− , text

32− , time

33− , 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+

3438 if !impl(ghcjs)

35− build-depends: katip

36− , katip-elasticsearch

37− , optparse-applicative

38− default-language: Haskell2010

39− default-extensions: RankNTypes

40− DataKinds

41− FlexibleContexts

42− FlexibleInstances

43− LambdaCase

44− OverloadedStrings

45− ScopedTypeVariables

46− DeriveGeneric

47− ConstraintKinds

48− RecordWildCards

49− 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> {} }:

2+

3+pkgs.mkShell {

4+ buildInputs = [

5+ pkgs.ghc

6+ pkgs.haskellPackages.cabal-install

7+ pkgs.zlib

8+ ];

9+}

src/Control/Logger.hs+65−11

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

1−

1+{-# LANGUAGE CPP #-}

22module Control.Logger

33 ( Logger

44 , loggerContext

5+ , scrubber

6+ , censor

7+ , censorWith

58 , logMsg

69 , logMsgWith

710 , logInfo

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

39−import Control.Logger.Orphans ()

46+import Control.Logger.Orphans ()

47+import Control.Monad

4048import Control.Monad.Catch

41−import qualified Data.List as List

42−import Data.Text (Text)

43−import qualified Data.Text as Text

49+import Control.Monad.IO.Class

50+import qualified Data.List as List

51+import Data.Monoid

52+import Data.Text (Text)

53+import qualified Data.Text as Text

4454import Data.Time

4555import GHC.Stack

46−import Katip (ToObject(..))

56+import Katip (ToObject (..))

4757import System.Log.FastLogger

48−import Text.Shakespeare.Text (st)

58+import Text.Shakespeare.Text (st)

4959

5060logError

5161 :: (LoggingMonad r m)

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

99109 -> m ()

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

101111

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+

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

103157tryLogError

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

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

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

150204

151205silentLogger :: Logger

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

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

153207

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

155209-- stderrLogger.

156210flushingFastFunc

157211 :: LogSeverity -> LoggerSet -> Logger

158212flushingFastFunc minLogLevel loggerSet =

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

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

160214 when (logLevel >= minLogLevel) $ do

161215 ts <- getCurrentTime

162216 pushLogStr loggerSet

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

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

181235fastFunc :: LoggerSet -> Logger

182236fastFunc loggerSet =

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

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

184238

185239type LogSource = Text

186240

187241-- | Default logger tests and same things.

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

189243defaultFastFunc loc minLogLevel loggerSet =

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

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

191245 ts <- getCurrentTime

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

193247

src/Control/Logger/Internal.hs+29−8

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

11{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE NamedFieldPuns #-}

3+{-# LANGUAGE CPP #-}

24

35module Control.Logger.Internal

46 ( Logger(..)

57 , loggerContext

68 , loggerAction

9+ , scrubber

710 , runLogger

811 , LogSeverity(..)

912 , LoggingMonad

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

1316

1417import Control.Has

1518import Control.Lens

19+import Control.Monad.IO.Class

1620import Control.DeepSeq

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

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

1822import Data.Text (Text)

19−import GHC.Generics (Generic)

23+import Data.Monoid

2024import GHC.Stack

2125

2226

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

3034instance ToJSON LogSeverity

3135instance FromJSON LogSeverity

3236

33−data Logger

34− = Logger

37+data Logger = Logger

3538 { _loggerContext :: Object

39+ , _scrubber :: Endo Text

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

3741 } deriving Generic

3842

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

4046

4147makeLenses ''Logger

4248

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

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

4653 where ctx' = ctx1 <> ctx2

4754

4855instance Monoid Logger where

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

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

5057

5158type LoggingMonad r m =

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

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

7077 liftIO $ runLogger logger callStack s t

7178

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

73−runLogger (Logger ctx logger) = logger ctx

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+3−63

@@ -5,28 +5,21 @@ module Control.Logger.Katip

55 ( logSeverityToKSeverity

66 , KatipContextTState(..)

77 , getKatipLogger

8− , ourFormatter

9− , ourMapping

8+ , ourItemJson

109 , katipIndexNameString

11− , reopenableFileLog

1210 ) where

1311

1412import Control.EnvT

1513import Control.Has.Katip ()

1614import Control.Lens hiding ((.=))

1715import Control.Logger.Internal

18−import Control.Logger.Katip.Scribes.Reopenable

1916import Data.Aeson hiding (Error)

20−import qualified Data.HashMap.Strict as HM

21−import Data.Proxy as P

2217import Data.Text (Text)

2318import qualified Data.Text as T

2419import qualified Data.Text.Lazy.Builder as T.Builder

2520import Katip as K hiding (logMsg)

26−import Katip.Core (ItemFunc(..), LocJs(..), ProcessIDJs(..))

21+import Katip.Core (LocJs(..), ProcessIDJs(..))

2722import Katip.Monadic (KatipContextTState(..))

28−import Katip.Scribes.ElasticSearch

29−import Katip.Scribes.ElasticSearch.Internal as K

3023

3124

3225logSeverityToKSeverity :: LogSeverity -> Severity

@@ -37,59 +30,6 @@ logSeverityToKSeverity = \case

3730 Error -> ErrorS

3831

3932

40−-- | Adds the @rev-hash@ value to each record.

41−-- Early we copied `msg` to `msg-keyword` here but drop it

42−-- because purpose of this duplication is not clear.

43−ourFormatter

44− :: Text

45− -- ^ git revision string

46− -> Verbosity

47− -> ItemFunc Value

48−ourFormatter gitRev verb = ItemFunc $ \item -> go $ ourItemJson verb item

49− where

50− go :: Value -> Value

51− go = \case

52− Object h -> Object $ setRev h

53− x -> x -- drop exception here?

54− where

55− setRev :: HM.HashMap Text Value -> HM.HashMap Text Value

56− setRev = HM.insert "rev-hash" (toJSON gitRev)

57−

58−ourMapping :: K.MappingName ESV5 -> Value

59−ourMapping mn = object

60− [fromMappingName prx mn .= object ["properties" .= object prs]]

61− where

62− prs =

63− [ unanalyzedString "thread"

64− , unanalyzedString "sev"

65− , unanalyzedString "pid"

66− -- ns is frequently fulltext searched

67− , analyzedString "ns"

68− -- we want message to be fulltext searchable

69− , analyzedString "msg"

70− -- we want to group by the message as well

71− , unanalyzedString "msg-keyword"

72− -- we want to group by revision hash

73− , unanalyzedString "rev-hash"

74− , "loc" .= locType

75− , unanalyzedString "host"

76− , unanalyzedString "env"

77− , "at" .= dateType

78− , unanalyzedString "app"

79− ]

80− prx = P.Proxy :: P.Proxy ESV5

81− unanalyzedString k = k .= unanalyzedStringSpec prx

82− analyzedString k = k .= analyzedStringSpec prx

83− locType = object ["properties" .= object locPairs]

84− locPairs =

85− [ unanalyzedString "loc_pkg"

86− , unanalyzedString "loc_mod"

87− , unanalyzedString "loc_ln"

88− , unanalyzedString "loc_fn"

89− , unanalyzedString "loc_col"

90− ]

91− dateType = object ["format" .= esDateFormat, "type" .= String "date"]

92−

9333katipIndexNameString :: Text

9434katipIndexNameString = "antorica-b2b-logs"

9535

@@ -116,7 +56,7 @@ instance LogItem Object where

11656 payloadKeys _ _ = AllKeys

11757

11858getKatipLogger :: KatipContextTState -> Logger

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

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

12060 $ \ ctx stack s msg ->

12161 let ?callStack = stack

12262 in

src/Control/Logger/Katip/Scribes/Reopenable.hsdeleted−19

@@ -1,19 +0,0 @@

1−module Control.Logger.Katip.Scribes.Reopenable where

2−

3−import Katip

4−import Katip.Scribes.Handle.FileOwner

5−

6−-- | Utility function to create scribe using the 'FileOwner'

7−-- inside. Returns new scribe and action to reopen the log

8−-- file. Reopening is performed asyncronously.

9−reopenableFileLog

10− :: FilePath

11− -> (forall a. LogItem a => ItemFormatter a)

12− -> PermitFunc

13− -> Verbosity

14− -> IO (Scribe, IO ())

15−reopenableFileLog fPath formatter permitF verbosity = do

16− owner <- newFileOwner fPath defaultFileOwnerSettings

17− s <- mkFileOwnerScribeWithFormatter formatter (ColorLog False)

18− owner permitF verbosity

19− return (s, fileOwnerControl owner ReopenMsg)

src/Control/Logger/Katip/Utils.hs+36−16

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

1−{-# LANGUAGE ImplicitParams #-}

1+{-# LANGUAGE CPP #-}

22

33module Control.Logger.Katip.Utils

44 ( katipIndexNameString

@@ -6,8 +6,6 @@ module Control.Logger.Katip.Utils

66 , LogFormat(..)

77 , registerFileScribe

88 , setLoggingCtx

9− , ourFormatter

10− , ourMapping

119 , getKatipLogger

1210 , logSeverityToKSeverity

1311 ) where

@@ -21,18 +19,36 @@ import Control.Logger.Internal as L

2119import Control.Logger.Katip as L

2220import Data.Aeson hiding (Error)

2321import Data.Aeson.Text

24−import qualified Data.ByteString.Builder as B.Builder

22+#if MIN_VERSION_aeson(2,0,0)

23+import qualified Data.Aeson.KeyMap as HM

24+import qualified Data.Aeson.Key as HM

25+#else

2526import qualified Data.HashMap.Strict as HM

27+#endif

2628import Data.Text (Text)

29+import qualified Data.Text.Lazy as T

2730import qualified Data.Text.Lazy.Builder as T.Builder

28−import qualified Data.Text.Lazy.Encoding as T.Lazy

2931import Katip as K hiding (logMsg)

30−import Katip.Core (ItemFunc(..))

3132import Katip.Monadic (KatipContextTState(..))

3233import qualified Katip.Scribes.Handle as K

3334import System.IO

3435

3536

37+#if MIN_VERSION_aeson(2,0,0)

38+type KeyMap v = HM.KeyMap v

39+textToKey :: Text -> Key

40+textToKey = HM.fromText

41+keyToText :: Key -> Text

42+keyToText = HM.toText

43+#else

44+type KeyMap v = HM.HashMap Text v

45+type Key = Text

46+textToKey :: Text -> Key

47+textToKey = id

48+keyToText :: Key -> Text

49+keyToText = id

50+#endif

51+

3652-- | How to format logs

3753data LogFormat

3854 = LogBracket -- ^ use `bracketFormat`

@@ -56,38 +72,42 @@ registerFileScribe gitRev verbosity format filePath permitF additions logenv =

5672 formatter = case format of

5773 LogBracket -> customBracketFormat additions'

5874 LogJson -> customJsonFormat gitRev additions'

59− additions' = HM.fromList . map (fmap String) $ additions

75+ additions'

76+ = HM.fromList

77+ . map (\(k, v) -> (textToKey k, String v))

78+ $ additions

6079

6180-- | JSON formatter that adds the specified fields to the output

6281customJsonFormat

63− :: forall a. LogItem a => Text -> HM.HashMap Text Value -> ItemFormatter a

82+ :: forall a. LogItem a => Text -> KeyMap Value -> ItemFormatter a

6483customJsonFormat gitRev additions withColor verb i = (mappend "\n") $

6584 -- Here we reimplement the standard formater because we want the

6685 -- additional key/value pairs to be added at the top level.

6786 -- So we can't use the LogWithAdditions like we do for bracket format

68− B.Builder.lazyByteString . T.Lazy.encodeUtf8 . T.Builder.toLazyText $

87+ T.Builder.fromText $

6988 K.colorBySeverity withColor (_itemSeverity i) $

70− encodeToTextBuilder (extend $ applyItemFunc (ourFormatter gitRev verb) i)

89+ (T.toStrict . encodeToLazyText) (extend $ ourItemJson verb i)

7190 where

72− extend (Object o) = Object $ HM.union additions o

91+ extend (Object o) = Object $ HM.union additions' o

7392 extend v = v

93+ additions' = HM.insert "rev-hash" (toJSON gitRev) additions

7494

7595-- | Bracket formatter that adds the specified fields to the output

7696customBracketFormat

77− :: forall a. LogItem a => HM.HashMap Text Value -> ItemFormatter a

97+ :: forall a. LogItem a => KeyMap Value -> ItemFormatter a

7898customBracketFormat additions withColor verb i =

7999 bracketFormat withColor verb (LogWithAdditions additions <$> i)

80100

81101-- | Log item payload that adds the specified additional key/value pairs

82102-- to the output on at verbosity levels

83−data LogWithAdditions a = LogWithAdditions (HM.HashMap Text Value) a

103+data LogWithAdditions a = LogWithAdditions (KeyMap Value) a

84104 deriving (Show)

85105

86106instance LogItem a => LogItem (LogWithAdditions a) where

87107 payloadKeys v (LogWithAdditions additions a) =

88108 case payloadKeys v a of

89109 AllKeys -> AllKeys

90− SomeKeys keys -> SomeKeys (HM.keys additions ++ keys)

110+ SomeKeys keys -> SomeKeys (map keyToText (HM.keys additions) ++ keys)

91111

92112instance ToObject a => ToObject (LogWithAdditions a) where

93113 toObject (LogWithAdditions additions a) =

@@ -100,5 +120,5 @@ setLoggingCtx

100120 -> ReaderT r m a

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

102122 where

103− go (Logger ctx f) =

104− Logger (ctx <> ctx') f

123+ go (Logger ctx scrbber f) =

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

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