git.iko.soy/typeable/control-logger
on d382e07 help sign in
2478ebf
swap
0 ahead, 25 behind
10 files changed+268−201
since splitsnapshots
unifiedsplit
.gitignore−3 README.md−3 control-logger.cabal+46−51 default.nix−9 src/Control/Logger.hs+11−65 src/Control/Logger/Internal.hs+8−29 src/Control/Logger/Katip.hs+130−4 src/Control/Logger/Katip/Scribes/Reopenable.hs+19 src/Control/Logger/Katip/Utils.hs+52−35 src/Control/Logger/Orphans.hs+2−2
.gitignoredeleted−3
@@ -1,3 +0,0 @@
1−.stack-work
2−*~
3−*.swp
README.mddeleted−3
@@ -1,3 +0,0 @@
1−# control-logger
2−
3−Utilities for logging
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+130−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,91 @@ 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+-- | Doubles the value of @msg@ key into the @msg-keyword@ and adds
98+-- the @rev-hash@ value to each record. The @msg-keyword@ is needed to
99+-- group errors by message. The @rev-hash@ is needed for many purposes
100+-- and for grouping as well.
101+ourFormatter
102+ :: Text
103+ -- ^ git revision string
104+ -> Verbosity
105+ -> ItemFunc Value
106+ourFormatter gitRev verb = ItemFunc $ \item -> go $ ourItemJson verb item
107+ where
108+ go :: Value -> Value
109+ go = \case
110+ Object h -> Object $ setRev $ dupMsg h
111+ x -> x -- drop exception here?
112+ where
113+ setRev :: HM.HashMap Text Value -> HM.HashMap Text Value
114+ setRev = HM.insert "rev-hash" (toJSON gitRev)
115+ dupMsg :: HM.HashMap Text Value -> HM.HashMap Text Value
116+ dupMsg m = HM.alter (const $ HM.lookup "msg" m) "msg-keyword" m
117+
118+ourMapping :: K.MappingName ESV5 -> Value
119+ourMapping mn = object
120+ [fromMappingName prx mn .= object ["properties" .= object prs]]
121+ where
122+ prs =
123+ [ unanalyzedString "thread"
124+ , unanalyzedString "sev"
125+ , unanalyzedString "pid"
126+ -- ns is frequently fulltext searched
127+ , analyzedString "ns"
128+ -- we want message to be fulltext searchable
129+ , analyzedString "msg"
130+ -- we want to group by the message as well
131+ , unanalyzedString "msg-keyword"
132+ -- we want to group by revision hash
133+ , unanalyzedString "rev-hash"
134+ , "loc" .= locType
135+ , unanalyzedString "host"
136+ , unanalyzedString "env"
137+ , "at" .= dateType
138+ , unanalyzedString "app"
139+ ]
140+ prx = P.Proxy :: P.Proxy ESV5
141+ unanalyzedString k = k .= unanalyzedStringSpec prx
142+ analyzedString k = k .= analyzedStringSpec prx
143+ locType = object ["properties" .= object locPairs]
144+ locPairs =
145+ [ unanalyzedString "loc_pkg"
146+ , unanalyzedString "loc_mod"
147+ , unanalyzedString "loc_ln"
148+ , unanalyzedString "loc_fn"
149+ , unanalyzedString "loc_col"
150+ ]
151+ dateType = object ["format" .= esDateFormat, "type" .= String "date"]
32152
33153katipIndexNameString :: Text
34154katipIndexNameString = "antorica-b2b-logs"
@@ -51,12 +171,18 @@ ourItemJson verb item = formatItem $
51171 , "loc" .= fmap LocJs _itemLoc
52172 ]
53173
174+-- | Return empty server if Nothing
175+maybeElastic :: Maybe ElasticServer -> ElasticServer
176+maybeElastic = \case
177+ Nothing -> ElasticServer Nothing Nothing Nothing
178+ Just a -> a
179+
54180instance LogItem Object where
55181 payloadKeys V0 _ = SomeKeys []
56182 payloadKeys _ _ = AllKeys
57183
58184getKatipLogger :: KatipContextTState -> Logger
59−getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx) mempty
185+getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx)
60186 $ \ ctx stack s msg ->
61187 let ?callStack = stack
62188 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