@@ -0,0 +1,141 @@
1+{-# LANGUAGE ImplicitParams #-}
2+
3+module Control.Logger.Katip.Utils
4+ ( katipIndexNameString
5+ , module Katip.Monadic
6+ , ElasticServer(..)
7+ , elasticServer
8+ , maybeElastic
9+ , registerElastic
10+ , LogFormat(..)
11+ , registerFileScribe
12+ , setLoggingCtx
13+ , ourFormatter
14+ , ourMapping
15+ , getKatipLogger
16+ , logSeverityToKSeverity
17+ ) where
18+
19+import Control.EnvT
20+import Control.Exception
21+import Control.Has
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
42+import System.IO
43+
44+
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+ )
72+
73+-- | How to format logs
74+data LogFormat
75+ = LogBracket -- ^ use `bracketFormat`
76+ | LogJson -- ^ use `jsonFormat`
77+ deriving (Eq, Show)
78+
79+registerFileScribe
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
86+ let
87+ fileScribe = scribe_
88+ { scribeFinalizer = scribeFinalizer scribe_ `finally` hClose h
89+ }
90+ registerScribe "file" fileScribe defaultScribeSettings logenv
91+ where
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
97+
98+-- | JSON formatter that adds the specified fields to the output
99+customJsonFormat
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)
108+ where
109+ extend (Object o) = Object $ HM.union additions o
110+ extend v = v
111+
112+-- | Bracket formatter that adds the specified fields to the output
113+customBracketFormat
114+ :: forall a. LogItem a => HM.HashMap Text Value -> ItemFormatter a
115+customBracketFormat additions withColor verb i =
116+ bracketFormat withColor verb (LogWithAdditions additions <$> i)
117+
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
121+ deriving (Show)
122+
123+instance LogItem a => LogItem (LogWithAdditions a) where
124+ payloadKeys v (LogWithAdditions additions a) =
125+ case payloadKeys v a of
126+ AllKeys -> AllKeys
127+ SomeKeys keys -> SomeKeys (HM.keys additions ++ keys)
128+
129+instance ToObject a => ToObject (LogWithAdditions a) where
130+ toObject (LogWithAdditions additions a) =
131+ HM.union additions (toObject a)
132+
133+setLoggingCtx
134+ :: (Has Logger r, Monad m)
135+ => Object
136+ -> ReaderT r m a
137+ -> ReaderT r m a
138+setLoggingCtx ctx' = local (part %~ go)
139+ where
140+ go (Logger ctx f) =
141+ Logger (ctx <> ctx') f