a5ad7be...master · typeable/control-logger

git.iko.soy/typeable/control-logger

on master help sign in

.gitignorenew file+3

since splitsnapshots

unifiedsplit

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

1+.stack-work

2+*~

3+*.swp

README.mdnew file+3

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

1+# control-logger

3+Utilities for logging

control-logger.cabal+51−45

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

8library

9− hs-source-dirs: src

9+ hs-source-dirs: src

10− ghc-options: -Wall

10+ ghc-options: -Wall

11+

11 if !impl(ghcjs)

12 if !impl(ghcjs)

12− exposed-modules: Control.Logger

13+ exposed-modules:

13− Control.Logger.Katip

14+ Control.Logger

14− Control.Logger.Katip.Scribes.Reopenable

15+ Control.Logger.Katip

15− Control.Logger.Katip.Utils

16+ Control.Logger.Katip.Utils

16− Control.Logger.Orphans

17+ Control.Logger.Orphans

18+

17− exposed-modules: Control.Logger.Internal

19+ exposed-modules: Control.Logger.Internal

18− build-depends: base

20+ build-depends:

19− , aeson

21+ , aeson

20− , bloodhound

22+ , base >=4.11

21− , bytestring

23+ , bytestring

22− , control-has

24+ , control-has

25+ , control-has-katip

23− , deepseq

26+ , deepseq

24− , exceptions

27+ , exceptions

25− , fast-logger

28+ , fast-logger >=2.4.11

26− , http-client

29+ , http-client

27− , lens

30+ , lens

28− , monad-logger

31+ , monad-logger

29− , mtl

32+ , mtl

30− , shakespeare

33+ , shakespeare

31− , text

34+ , text

32− , time

35+ , time

33− , unordered-containers

36+ , unordered-containers

37+

34 if !impl(ghcjs)

38 if !impl(ghcjs)

35− build-depends: katip

39+ build-depends:

36− , katip-elasticsearch

40+ , katip >=0.8.8.0

37− , optparse-applicative

41+ , optparse-applicative

42+

38− default-language: Haskell2010

43+ default-language: Haskell2010

39− default-extensions: RankNTypes

44+ default-extensions:

45+ ConstraintKinds

40− DataKinds

46+ DataKinds

47+ DeriveGeneric

41− FlexibleContexts

48+ FlexibleContexts

42− FlexibleInstances

49+ FlexibleInstances

43− LambdaCase

50+ LambdaCase

44− OverloadedStrings

51+ OverloadedStrings

45− ScopedTypeVariables

52+ RankNTypes

46− DeriveGeneric

47− ConstraintKinds

48− RecordWildCards

53+ RecordWildCards

54+ ScopedTypeVariables

49− 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+67−12

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

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

99 -> m ()

109 -> m ()

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

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

101

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

155+

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

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

103tryLogError

157tryLogError

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

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

@@ -142,20 +196,21 @@ logExceptions ma = catch ma $ \e -> do

142 throwM e

196 throwM e

143

197

144oneoffLog :: MonadIO m => Logger -> LogSeverity -> Text -> m ()

198oneoffLog :: MonadIO m => Logger -> LogSeverity -> Text -> m ()

199+oneoffLog logger s t =

145−oneoffLog logger s t = flip runReaderT logger $ logMsg s t

200+ withFrozenCallStack (flip runReaderT logger $ logMsg s t)

146

201

147fileLogger :: MonadIO m => FilePath -> m Logger

202fileLogger :: MonadIO m => FilePath -> m Logger

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

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

149

204

150silentLogger :: Logger

205silentLogger :: Logger

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

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

152

207

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

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

154-- stderrLogger.

209-- stderrLogger.

155flushingFastFunc

210flushingFastFunc

156 :: LogSeverity -> LoggerSet -> Logger

211 :: LogSeverity -> LoggerSet -> Logger

157flushingFastFunc minLogLevel loggerSet =

212flushingFastFunc minLogLevel loggerSet =

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

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

159 when (logLevel >= minLogLevel) $ do

214 when (logLevel >= minLogLevel) $ do

160 ts <- getCurrentTime

215 ts <- getCurrentTime

161 pushLogStr loggerSet

216 pushLogStr loggerSet

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

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

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

180fastFunc :: LoggerSet -> Logger

235fastFunc :: LoggerSet -> Logger

181fastFunc loggerSet =

236fastFunc loggerSet =

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

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

183

238

184type LogSource = Text

239type LogSource = Text

185

240

186-- | Default logger tests and same things.

241-- | Default logger tests and same things.

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

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

188defaultFastFunc loc minLogLevel loggerSet =

243defaultFastFunc loc minLogLevel loggerSet =

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

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

190 ts <- getCurrentTime

245 ts <- getCurrentTime

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

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

192

247

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

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

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

70 liftIO $ runLogger logger callStack s t

77 liftIO $ runLogger logger callStack s t

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

79runLogger :: 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+5−130

@@ -2,60 +2,26 @@

2{-# OPTIONS_GHC -fno-warn-orphans #-}

4module Control.Logger.Katip

5− ( ElasticServer(..)

6− , logSeverityToKSeverity

5+ ( logSeverityToKSeverity

7− , registerElastic

8− , maybeElastic

9 , KatipContextTState(..)

6 , KatipContextTState(..)

10 , getKatipLogger

7 , getKatipLogger

11− , ourFormatter

8+ , ourItemJson

12− , ourMapping

13 , katipIndexNameString

9 , katipIndexNameString

14− , reopenableFileLog

15 ) where

10 ) where

17import Control.EnvT

12import Control.EnvT

13+import Control.Has.Katip ()

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

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

19import Control.Logger.Internal

15import Control.Logger.Internal

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

21import Data.Aeson hiding (Error)

16import Data.Aeson hiding (Error)

22−import Data.ByteString (ByteString)

23−import qualified Data.HashMap.Strict as HM

24−import Data.Proxy as P

25import Data.Text (Text)

17import Data.Text (Text)

26import qualified Data.Text as T

18import qualified Data.Text as T

27−import qualified Data.Text.Encoding as T

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

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

29−import Database.V5.Bloodhound

30import Katip as K hiding (logMsg)

20import Katip as K hiding (logMsg)

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

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

32import Katip.Monadic (KatipContextTState(..))

22import Katip.Monadic (KatipContextTState(..))

33−import Katip.Scribes.ElasticSearch

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

35−import Network.HTTP.Client

38−data ElasticServer = ElasticServer

39− { _esServer :: !(Maybe Server)

40− , _esUsername :: !(Maybe ByteString)

41− , _esPassword :: !(Maybe ByteString)

42− } deriving (Eq, Show)

43−

44−instance FromJSON ElasticServer where

45− parseJSON = withObject "ElasticServer" $ \obj -> ElasticServer

46− <$> (obj .: "server")

47− <*> (fmap T.encodeUtf8 <$> (obj .: "username"))

48− <*> (fmap T.encodeUtf8 <$> (obj .: "password"))

49−

50−instance ToJSON ElasticServer where

51− toJSON es = object

52− [ "server" .= fmap fromServer (_esServer es)

53− , "username" .= fmap T.decodeUtf8 (_esUsername es)

54− , "password" .= fmap T.decodeUtf8 (_esPassword es)

55− ]

56− where

57− fromServer (Server s) = s

58−

59logSeverityToKSeverity :: LogSeverity -> Severity

25logSeverityToKSeverity :: LogSeverity -> Severity

60logSeverityToKSeverity = \case

26logSeverityToKSeverity = \case

61 Debug -> DebugS

27 Debug -> DebugS

@@ -63,91 +29,6 @@ logSeverityToKSeverity = \case

63 Warn -> WarningS

29 Warn -> WarningS

64 Error -> ErrorS

30 Error -> ErrorS

66−registerElastic

67− :: Text

68− -- ^ git revision

69− -> Verbosity

70− -> ElasticServer

71− -> PermitFunc

72− -> LogEnv

73− -> IO LogEnv

74−registerElastic gitRev verbosity ElasticServer{..} permitF env =

75− case _esServer of

76− Nothing -> return env

77− Just server -> do

78− elastic <- do

79− mgr <- newManager defaultManagerSettings

80− let

81− bloodhoundEnv = (mkBHEnv server mgr)

82− { bhRequestHook = requestHook }

83− mkEsScribe cfg bloodhoundEnv permitF verbosity

84− registerScribe "elastic" elastic defaultScribeSettings env

85− where

86− cfg = (defaultEsScribeCfgV5 ixName mappingName)

87− { essItemFormatter = ourFormatter gitRev

88− , essIndexMappingValue = ourMapping mappingName }

89− where

90− ixName = IndexName katipIndexNameString

91− mappingName = MappingName "logs"

92− requestHook = return . case (_esUsername, _esPassword) of

93− (Just u, Just p) -> applyBasicAuth u p

94− _ -> id

95−

96−-- | Doubles the value of @msg@ key into the @msg-keyword@ and adds

97−-- the @rev-hash@ value to each record. The @msg-keyword@ is needed to

98−-- group errors by message. The @rev-hash@ is needed for many purposes

99−-- and for grouping as well.

100−ourFormatter

101− :: Text

102− -- ^ git revision string

103− -> Verbosity

104− -> ItemFunc Value

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

106− where

107− go :: Value -> Value

108− go = \case

109− Object h -> Object $ setRev $ dupMsg h

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

111− where

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

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

114− dupMsg :: HM.HashMap Text Value -> HM.HashMap Text Value

115− dupMsg m = HM.alter (const $ HM.lookup "msg" m) "msg-keyword" m

116−

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

118−ourMapping mn = object

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

120− where

121− prs =

122− [ unanalyzedString "thread"

123− , unanalyzedString "sev"

124− , unanalyzedString "pid"

125− -- ns is frequently fulltext searched

126− , analyzedString "ns"

127− -- we want message to be fulltext searchable

128− , analyzedString "msg"

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

130− , unanalyzedString "msg-keyword"

131− -- we want to group by revision hash

132− , unanalyzedString "rev-hash"

133− , "loc" .= locType

134− , unanalyzedString "host"

135− , unanalyzedString "env"

136− , "at" .= dateType

137− , unanalyzedString "app"

138− ]

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

140− unanalyzedString k = k .= unanalyzedStringSpec prx

141− analyzedString k = k .= analyzedStringSpec prx

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

143− locPairs =

144− [ unanalyzedString "loc_pkg"

145− , unanalyzedString "loc_mod"

146− , unanalyzedString "loc_ln"

147− , unanalyzedString "loc_fn"

148− , unanalyzedString "loc_col"

149− ]

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

151

152katipIndexNameString :: Text

33katipIndexNameString :: Text

153katipIndexNameString = "antorica-b2b-logs"

34katipIndexNameString = "antorica-b2b-logs"

@@ -170,18 +51,12 @@ ourItemJson verb item = formatItem $

170 , "loc" .= fmap LocJs _itemLoc

51 , "loc" .= fmap LocJs _itemLoc

171 ]

52 ]

172

173−-- | Return empty server if Nothing

174−maybeElastic :: Maybe ElasticServer -> ElasticServer

175−maybeElastic = \case

176− Nothing -> ElasticServer Nothing Nothing Nothing

177− Just a -> a

178−

179instance LogItem Object where

54instance LogItem Object where

180 payloadKeys V0 _ = SomeKeys []

55 payloadKeys V0 _ = SomeKeys []

181 payloadKeys _ _ = AllKeys

56 payloadKeys _ _ = AllKeys

182

183getKatipLogger :: KatipContextTState -> Logger

58getKatipLogger :: KatipContextTState -> Logger

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

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

185 $ \ ctx stack s msg ->

60 $ \ ctx stack s msg ->

186 let ?callStack = stack

61 let ?callStack = stack

187 in

62 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+35−52

@@ -1,17 +1,11 @@

1−{-# LANGUAGE ImplicitParams #-}

1+{-# LANGUAGE CPP #-}

3module Control.Logger.Katip.Utils

4 ( katipIndexNameString

5 , module Katip.Monadic

6− , ElasticServer(..)

7− , elasticServer

8− , maybeElastic

9− , registerElastic

10 , LogFormat(..)

6 , LogFormat(..)

11 , registerFileScribe

7 , registerFileScribe

12 , setLoggingCtx

8 , setLoggingCtx

13− , ourFormatter

14− , ourMapping

15 , getKatipLogger

9 , getKatipLogger

16 , logSeverityToKSeverity

10 , logSeverityToKSeverity

17 ) where

11 ) where

@@ -25,50 +19,35 @@ import Control.Logger.Internal as L

25import Control.Logger.Katip as L

19import Control.Logger.Katip as L

26import Data.Aeson hiding (Error)

20import Data.Aeson hiding (Error)

27import Data.Aeson.Text

21import Data.Aeson.Text

28−import Data.ByteString (ByteString)

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

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

23+import qualified Data.Aeson.KeyMap as HM

24+import qualified Data.Aeson.Key as HM

25+#else

30import qualified Data.HashMap.Strict as HM

26import qualified Data.HashMap.Strict as HM

27+#endif

31import Data.Text (Text)

28import Data.Text (Text)

32−import qualified Data.Text as T

29+import qualified Data.Text.Lazy as T

33−import Data.Text.Encoding

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

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

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

36−import Database.V5.Bloodhound as BH

37import Katip as K hiding (logMsg)

31import Katip as K hiding (logMsg)

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

39import Katip.Monadic (KatipContextTState(..))

32import Katip.Monadic (KatipContextTState(..))

40import qualified Katip.Scribes.Handle as K

33import qualified Katip.Scribes.Handle as K

41−import Options.Applicative

42import System.IO

34import System.IO

45−elasticServer :: Parser ElasticServer

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

46−elasticServer =

38+type KeyMap v = HM.KeyMap v

47− ElasticServer

39+textToKey :: Text -> Key

48− <$> optional elasticServerAddress

40+textToKey = HM.fromText

49− <*> optional elasticServerUsername

41+keyToText :: Key -> Text

50− <*> optional elasticServerPassword

42+keyToText = HM.toText

51−

43+#else

52−elasticServerAddress :: Parser Server

44+type KeyMap v = HM.HashMap Text v

53−elasticServerAddress = Server <$> option

45+type Key = Text

54− (T.pack <$> str)

46+textToKey :: Text -> Key

55− (long "elastic-server" <> metavar "ELASTIC_SERVER" <> help

47+textToKey = id

56− "Address of elastic search server"

48+keyToText :: Key -> Text

57− )

49+keyToText = id

58−

50+#endif

59−elasticServerUsername :: Parser ByteString

60−elasticServerUsername = option

61− (encodeUtf8 . T.pack <$> str)

62− (long "elastic-server-username" <> metavar "ELASTIC_SERVER_USERNAME" <> help

63− "Elastic server username"

64− )

65−

66−elasticServerPassword :: Parser ByteString

67−elasticServerPassword = option

68− (encodeUtf8 . T.pack <$> str)

69− (long "elastic-server-password" <> metavar "ELASTIC_SERVER_PASSWORD" <> help

70− "Elastic server password"

71− )

73-- | How to format logs

52-- | How to format logs

74data LogFormat

53data LogFormat

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

93 formatter = case format of

72 formatter = case format of

94 LogBracket -> customBracketFormat additions'

73 LogBracket -> customBracketFormat additions'

95 LogJson -> customJsonFormat gitRev additions'

74 LogJson -> customJsonFormat gitRev additions'

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

75+ additions'

76+ = HM.fromList

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

78+ $ additions

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

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

99customJsonFormat

81customJsonFormat

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

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

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

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

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

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

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

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

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

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

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

87+ T.Builder.fromText $

106 K.colorBySeverity withColor (_itemSeverity i) $

88 K.colorBySeverity withColor (_itemSeverity i) $

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

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

108 where

90 where

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

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

110 extend v = v

92 extend v = v

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

111

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

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

113customBracketFormat

96customBracketFormat

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

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

115customBracketFormat additions withColor verb i =

98customBracketFormat additions withColor verb i =

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

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

117

100

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

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

119-- to the output on at verbosity levels

102-- to the output on at verbosity levels

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

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

121 deriving (Show)

104 deriving (Show)

122

105

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

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

124 payloadKeys v (LogWithAdditions additions a) =

107 payloadKeys v (LogWithAdditions additions a) =

125 case payloadKeys v a of

108 case payloadKeys v a of

126 AllKeys -> AllKeys

109 AllKeys -> AllKeys

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

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

128

111

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

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

130 toObject (LogWithAdditions additions a) =

113 toObject (LogWithAdditions additions a) =

@@ -137,5 +120,5 @@ setLoggingCtx

137 -> ReaderT r m a

120 -> ReaderT r m a

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

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

139 where

122 where

140− go (Logger ctx f) =

123+ go (Logger ctx scrbber f) =

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