master..9703d9f · typeable/control-logger

.gitignoredeleted−3

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

1−.stack-work

2−*~

3−*.swp

README.md+1−1

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

11# control-logger

22

3−Utilities for logging

3+Utilities for logging with DTT projects

control-logger.cabal+46−51

@@ -1,55 +1,50 @@

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

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

15+ Control.Logger.Katip.Utils

16+ Control.Logger.Orphans

17+ exposed-modules: Control.Logger.Internal

18+ build-depends: base

19+ , aeson

20+ , bloodhound

21+ , bytestring

22+ , control-has

23+ , control-has-katip

24+ , deepseq

25+ , exceptions

26+ , fast-logger

27+ , http-client

28+ , lens

29+ , monad-logger

30+ , mtl

31+ , shakespeare

32+ , text

33+ , time

34+ , unordered-containers

3835 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

36+ build-depends: katip

37+ , katip-elasticsearch

38+ , optparse-applicative

39+ default-language: Haskell2010

40+ default-extensions: RankNTypes

41+ DataKinds

42+ FlexibleContexts

43+ FlexibleInstances

44+ LambdaCase

45+ OverloadedStrings

46+ ScopedTypeVariables

47+ DeriveGeneric

48+ ConstraintKinds

49+ RecordWildCards

50+ 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 #-}

1+

22module Control.Logger

33 ( Logger

44 , loggerContext

5− , scrubber

6− , censor

7− , censorWith

85 , logMsg

96 , logMsgWith

107 , logInfo

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

3532 , compactCallStack

3633 , st

3734 , ToObject(..)

38− , withScrubber

39− , censoringWith

40− , censoring

4135 ) where

4236

4337import Control.Has

44−import Control.Lens hiding (censoring)

4538import Control.Logger.Internal

46−import Control.Logger.Orphans ()

47−import Control.Monad

39+import Control.Logger.Orphans ()

4840import Control.Monad.Catch

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

41+import qualified Data.List as List

42+import Data.Text (Text)

43+import qualified Data.Text as Text

5444import Data.Time

5545import GHC.Stack

56−import Katip (ToObject (..))

46+import Katip (ToObject(..))

5747import System.Log.FastLogger

58−import Text.Shakespeare.Text (st)

48+import Text.Shakespeare.Text (st)

5949

6050logError

6151 :: (LoggingMonad r m)

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

10999 -> m ()

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

111101

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−

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

157103tryLogError

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

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

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

204150

205151silentLogger :: Logger

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

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

207153

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

209155-- stderrLogger.

210156flushingFastFunc

211157 :: LogSeverity -> LoggerSet -> Logger

212158flushingFastFunc minLogLevel loggerSet =

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

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

214160 when (logLevel >= minLogLevel) $ do

215161 ts <- getCurrentTime

216162 pushLogStr loggerSet

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

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

235181fastFunc :: LoggerSet -> Logger

236182fastFunc loggerSet =

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

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

238184

239185type LogSource = Text

240186

241187-- | Default logger tests and same things.

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

243189defaultFastFunc loc minLogLevel loggerSet =

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

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

245191 ts <- getCurrentTime

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

247193

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

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

11{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE NamedFieldPuns #-}

3−{-# LANGUAGE CPP #-}

42

53module Control.Logger.Internal

64 ( Logger(..)

75 , loggerContext

86 , loggerAction

9− , scrubber

107 , runLogger

118 , LogSeverity(..)

129 , LoggingMonad

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

1613

1714import Control.Has

1815import Control.Lens

19−import Control.Monad.IO.Class

2016import Control.DeepSeq

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

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

2218import Data.Text (Text)

23−import Data.Monoid

19+import GHC.Generics (Generic)

2420import GHC.Stack

2521

2622

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

3430instance ToJSON LogSeverity

3531instance FromJSON LogSeverity

3632

37−data Logger = Logger

33+data Logger

34+ = Logger

3835 { _loggerContext :: Object

39− , _scrubber :: Endo Text

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

4137 } deriving Generic

4238

43−instance NFData Logger where

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

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

39+instance NFData Logger

4640

4741makeLenses ''Logger

4842

4943instance Semigroup Logger where

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

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

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

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

5346 where ctx' = ctx1 <> ctx2

5447

5548instance Monoid Logger where

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

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

5750

5851type LoggingMonad r m =

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

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

7770 liftIO $ runLogger logger callStack s t

7871

7972runLogger :: 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

73+runLogger (Logger ctx logger) = logger ctx

src/Control/Logger/Katip.hs+127−4

@@ -2,26 +2,61 @@

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

33

44module Control.Logger.Katip

5− ( logSeverityToKSeverity

5+ ( ElasticServer(..)

6+ , logSeverityToKSeverity

7+ , registerElastic

8+ , maybeElastic

69 , KatipContextTState(..)

710 , getKatipLogger

8− , ourItemJson

11+ , ourFormatter

12+ , ourMapping

913 , katipIndexNameString

14+ , reopenableFileLog

1015 ) where

1116

1217import Control.EnvT

1318import Control.Has.Katip ()

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

1520import Control.Logger.Internal

21+import Control.Logger.Katip.Scribes.Reopenable

1622import Data.Aeson hiding (Error)

23+import Data.ByteString (ByteString)

24+import qualified Data.HashMap.Strict as HM

25+import Data.Proxy as P

1726import Data.Text (Text)

1827import qualified Data.Text as T

28+import qualified Data.Text.Encoding as T

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

30+import Database.V5.Bloodhound

2031import Katip as K hiding (logMsg)

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

32+import Katip.Core (ItemFunc(..), LocJs(..), ProcessIDJs(..))

2233import Katip.Monadic (KatipContextTState(..))

34+import Katip.Scribes.ElasticSearch

35+import Katip.Scribes.ElasticSearch.Internal as K

36+import Network.HTTP.Client

2337

2438

39+data ElasticServer = ElasticServer

40+ { _esServer :: !(Maybe Server)

41+ , _esUsername :: !(Maybe ByteString)

42+ , _esPassword :: !(Maybe ByteString)

43+ } deriving (Eq, Show)

44+

45+instance FromJSON ElasticServer where

46+ parseJSON = withObject "ElasticServer" $ \obj -> ElasticServer

47+ <$> (obj .: "server")

48+ <*> (fmap T.encodeUtf8 <$> (obj .: "username"))

49+ <*> (fmap T.encodeUtf8 <$> (obj .: "password"))

50+

51+instance ToJSON ElasticServer where

52+ toJSON es = object

53+ [ "server" .= fmap fromServer (_esServer es)

54+ , "username" .= fmap T.decodeUtf8 (_esUsername es)

55+ , "password" .= fmap T.decodeUtf8 (_esPassword es)

56+ ]

57+ where

58+ fromServer (Server s) = s

59+

2560logSeverityToKSeverity :: LogSeverity -> Severity

2661logSeverityToKSeverity = \case

2762 Debug -> DebugS

@@ -29,6 +64,88 @@ logSeverityToKSeverity = \case

2964 Warn -> WarningS

3065 Error -> ErrorS

3166

67+registerElastic

68+ :: Text

69+ -- ^ git revision

70+ -> Verbosity

71+ -> ElasticServer

72+ -> PermitFunc

73+ -> LogEnv

74+ -> IO LogEnv

75+registerElastic gitRev verbosity ElasticServer{..} permitF env =

76+ case _esServer of

77+ Nothing -> return env

78+ Just server -> do

79+ elastic <- do

80+ mgr <- newManager defaultManagerSettings

81+ let

82+ bloodhoundEnv = (mkBHEnv server mgr)

83+ { bhRequestHook = requestHook }

84+ mkEsScribe cfg bloodhoundEnv permitF verbosity

85+ registerScribe "elastic" elastic defaultScribeSettings env

86+ where

87+ cfg = (defaultEsScribeCfgV5 ixName mappingName)

88+ { essItemFormatter = ourFormatter gitRev

89+ , essIndexMappingValue = ourMapping mappingName }

90+ where

91+ ixName = IndexName katipIndexNameString

92+ mappingName = MappingName "logs"

93+ requestHook = return . case (_esUsername, _esPassword) of

94+ (Just u, Just p) -> applyBasicAuth u p

95+ _ -> id

96+

97+-- | Adds the @rev-hash@ value to each record.

98+-- Early we copied `msg` to `msg-keyword` here but drop it

99+-- because purpose of this duplication is not clear.

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 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+

115+ourMapping :: K.MappingName ESV5 -> Value

116+ourMapping mn = object

117+ [fromMappingName prx mn .= object ["properties" .= object prs]]

118+ where

119+ prs =

120+ [ unanalyzedString "thread"

121+ , unanalyzedString "sev"

122+ , unanalyzedString "pid"

123+ -- ns is frequently fulltext searched

124+ , analyzedString "ns"

125+ -- we want message to be fulltext searchable

126+ , analyzedString "msg"

127+ -- we want to group by the message as well

128+ , unanalyzedString "msg-keyword"

129+ -- we want to group by revision hash

130+ , unanalyzedString "rev-hash"

131+ , "loc" .= locType

132+ , unanalyzedString "host"

133+ , unanalyzedString "env"

134+ , "at" .= dateType

135+ , unanalyzedString "app"

136+ ]

137+ prx = P.Proxy :: P.Proxy ESV5

138+ unanalyzedString k = k .= unanalyzedStringSpec prx

139+ analyzedString k = k .= analyzedStringSpec prx

140+ locType = object ["properties" .= object locPairs]

141+ locPairs =

142+ [ unanalyzedString "loc_pkg"

143+ , unanalyzedString "loc_mod"

144+ , unanalyzedString "loc_ln"

145+ , unanalyzedString "loc_fn"

146+ , unanalyzedString "loc_col"

147+ ]

148+ dateType = object ["format" .= esDateFormat, "type" .= String "date"]

32149

33150katipIndexNameString :: Text

34151katipIndexNameString = "antorica-b2b-logs"

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

51168 , "loc" .= fmap LocJs _itemLoc

52169 ]

53170

171+-- | Return empty server if Nothing

172+maybeElastic :: Maybe ElasticServer -> ElasticServer

173+maybeElastic = \case

174+ Nothing -> ElasticServer Nothing Nothing Nothing

175+ Just a -> a

176+

54177instance LogItem Object where

55178 payloadKeys V0 _ = SomeKeys []

56179 payloadKeys _ _ = AllKeys

57180

58181getKatipLogger :: KatipContextTState -> Logger

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

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

60183 $ \ ctx stack s msg ->

61184 let ?callStack = stack

62185 in

src/Control/Logger/Katip/Scribes/Reopenable.hsnew file+19

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

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

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

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE ImplicitParams #-}

22

33module Control.Logger.Katip.Utils

44 ( katipIndexNameString

55 , module Katip.Monadic

6+ , ElasticServer(..)

7+ , elasticServer

8+ , maybeElastic

9+ , registerElastic

610 , LogFormat(..)

711 , registerFileScribe

812 , setLoggingCtx

13+ , ourFormatter

14+ , ourMapping

915 , getKatipLogger

1016 , logSeverityToKSeverity

1117 ) where

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

1925import Control.Logger.Katip as L

2026import Data.Aeson hiding (Error)

2127import Data.Aeson.Text

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

28+import Data.ByteString (ByteString)

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

2630import qualified Data.HashMap.Strict as HM

27−#endif

2831import Data.Text (Text)

29−import qualified Data.Text.Lazy as T

32+import qualified Data.Text as T

33+import Data.Text.Encoding

3034import 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

3137import Katip as K hiding (logMsg)

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

3239import Katip.Monadic (KatipContextTState(..))

3340import qualified Katip.Scribes.Handle as K

41+import Options.Applicative

3442import System.IO

3543

3644

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

45+elasticServer :: Parser ElasticServer

46+elasticServer =

47+ ElasticServer

48+ <$> optional elasticServerAddress

49+ <*> optional elasticServerUsername

50+ <*> optional elasticServerPassword

51+

52+elasticServerAddress :: Parser Server

53+elasticServerAddress = Server <$> option

54+ (T.pack <$> str)

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

56+ "Address of elastic search server"

57+ )

58+

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

5172

5273-- | How to format logs

5374data LogFormat

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

7293 formatter = case format of

7394 LogBracket -> customBracketFormat additions'

7495 LogJson -> customJsonFormat gitRev additions'

75− additions'

76− = HM.fromList

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

78− $ additions

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

7997

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

8199customJsonFormat

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

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

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

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

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

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

87− T.Builder.fromText $

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

88106 K.colorBySeverity withColor (_itemSeverity i) $

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

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

90108 where

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

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

92110 extend v = v

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

94111

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

96113customBracketFormat

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

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

98115customBracketFormat additions withColor verb i =

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

100117

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

102119-- to the output on at verbosity levels

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

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

104121 deriving (Show)

105122

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

107124 payloadKeys v (LogWithAdditions additions a) =

108125 case payloadKeys v a of

109126 AllKeys -> AllKeys

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

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

111128

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

113130 toObject (LogWithAdditions additions a) =

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

120137 -> ReaderT r m a

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

122139 where

123− go (Logger ctx scrbber f) =

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

140+ go (Logger ctx f) =

141+ Logger (ctx <> ctx') 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.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