@@ -0,0 +1,141 @@
1+{-# LANGUAGE ImplicitParams #-}
3+module Control.Logger.Katip.Utils
4+ ( katipIndexNameString
5+ , module Katip.Monadic
16+ , logSeverityToKSeverity
20+import Control.Exception
22+import Control.Lens hiding ((.=))
23+import Control.Logger as L
24+import Control.Logger.Internal as L
25+import Control.Logger.Katip as L
26+import Data.Aeson hiding (Error)
27+import Data.Aeson.Text
28+import Data.ByteString (ByteString)
29+import qualified Data.ByteString.Builder as B.Builder
30+import qualified Data.HashMap.Strict as HM
31+import Data.Text (Text)
32+import qualified Data.Text as T
33+import Data.Text.Encoding
34+import 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
37+import Katip as K hiding (logMsg)
38+import Katip.Core (ItemFunc(..))
39+import Katip.Monadic (KatipContextTState(..))
40+import qualified Katip.Scribes.Handle as K
41+import Options.Applicative
45+elasticServer :: Parser ElasticServer
48+ <$> optional elasticServerAddress
49+ <*> optional elasticServerUsername
50+ <*> optional elasticServerPassword
52+elasticServerAddress :: Parser Server
53+elasticServerAddress = Server <$> option
55+ (long "elastic-server" <> metavar "ELASTIC_SERVER" <> help
56+ "Address of elastic search server"
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"
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"
73+-- | How to format logs
75+ = LogBracket -- ^ use `bracketFormat`
76+ | LogJson -- ^ use `jsonFormat`
80+ :: Text -> Verbosity -> LogFormat -> FilePath -> PermitFunc -> [(Text, Text)]
81+ -> LogEnv -> IO LogEnv
82+registerFileScribe gitRev verbosity format filePath permitF additions logenv =
83+ bracketOnError (openFile filePath AppendMode) hClose $ \h -> do
84+ scribe_ <- mkHandleScribeWithFormatter formatter
85+ (ColorLog False) h permitF verbosity
88+ { scribeFinalizer = scribeFinalizer scribe_ `finally` hClose h
90+ registerScribe "file" fileScribe defaultScribeSettings logenv
92+ formatter :: forall a. LogItem a => ItemFormatter a
93+ formatter = case format of
94+ LogBracket -> customBracketFormat additions'
95+ LogJson -> customJsonFormat gitRev additions'
96+ additions' = HM.fromList . map (fmap String) $ additions
98+-- | JSON formatter that adds the specified fields to the output
100+ :: forall a. LogItem a => Text -> HM.HashMap Text Value -> ItemFormatter a
101+customJsonFormat gitRev additions withColor verb i = (mappend "\n") $
102+ -- Here we reimplement the standard formater because we want the
103+ -- 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
105+ B.Builder.lazyByteString . T.Lazy.encodeUtf8 . T.Builder.toLazyText $
106+ K.colorBySeverity withColor (_itemSeverity i) $
107+ encodeToTextBuilder (extend $ applyItemFunc (ourFormatter gitRev verb) i)
109+ extend (Object o) = Object $ HM.union additions o
112+-- | Bracket formatter that adds the specified fields to the output
114+ :: forall a. LogItem a => HM.HashMap Text Value -> ItemFormatter a
115+customBracketFormat additions withColor verb i =
116+ bracketFormat withColor verb (LogWithAdditions additions <$> i)
118+-- | Log item payload that adds the specified additional key/value pairs
119+-- to the output on at verbosity levels
120+data LogWithAdditions a = LogWithAdditions (HM.HashMap Text Value) a
123+instance LogItem a => LogItem (LogWithAdditions a) where
124+ payloadKeys v (LogWithAdditions additions a) =
125+ case payloadKeys v a of
127+ SomeKeys keys -> SomeKeys (HM.keys additions ++ keys)
129+instance ToObject a => ToObject (LogWithAdditions a) where
130+ toObject (LogWithAdditions additions a) =
131+ HM.union additions (toObject a)
134+ :: (Has Logger r, Monad m)
138+setLoggingCtx ctx' = local (part %~ go)
141+ Logger (ctx <> ctx') f