@@ -2,60 +2,26 @@
22{-# OPTIONS_GHC -fno-warn-orphans #-}
33
44module Control.Logger.Katip
5− ( ElasticServer(..)
6− , logSeverityToKSeverity
7− , registerElastic
8− , maybeElastic
5+ ( logSeverityToKSeverity
96 , KatipContextTState(..)
107 , getKatipLogger
11− , ourFormatter
12− , ourMapping
8+ , ourItemJson
139 , katipIndexNameString
14− , reopenableFileLog
1510 ) where
1611
1712import Control.EnvT
13+import Control.Has.Katip ()
1814import Control.Lens hiding ((.=))
1915import Control.Logger.Internal
20−import Control.Logger.Katip.Scribes.Reopenable
2116import Data.Aeson hiding (Error)
22−import Data.ByteString (ByteString)
23−import qualified Data.HashMap.Strict as HM
24−import Data.Proxy as P
2517import Data.Text (Text)
2618import qualified Data.Text as T
27−import qualified Data.Text.Encoding as T
2819import qualified Data.Text.Lazy.Builder as T.Builder
29−import Database.V5.Bloodhound
3020import Katip as K hiding (logMsg)
31−import Katip.Core (ItemFunc(..), LocJs(..), ProcessIDJs(..))
21+import Katip.Core (LocJs(..), ProcessIDJs(..))
3222import Katip.Monadic (KatipContextTState(..))
33−import Katip.Scribes.ElasticSearch
34−import Katip.Scribes.ElasticSearch.Internal as K
35−import Network.HTTP.Client
3623
3724
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−
5925logSeverityToKSeverity :: LogSeverity -> Severity
6026logSeverityToKSeverity = \case
6127 Debug -> DebugS
@@ -63,91 +29,6 @@ logSeverityToKSeverity = \case
6329 Warn -> WarningS
6430 Error -> ErrorS
6531
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"]
15132
15233katipIndexNameString :: Text
15334katipIndexNameString = "antorica-b2b-logs"
@@ -170,18 +51,12 @@ ourItemJson verb item = formatItem $
17051 , "loc" .= fmap LocJs _itemLoc
17152 ]
17253
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−
17954instance LogItem Object where
18055 payloadKeys V0 _ = SomeKeys []
18156 payloadKeys _ _ = AllKeys
18257
18358getKatipLogger :: KatipContextTState -> Logger
184−getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx)
59+getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx) mempty
18560 $ \ ctx stack s msg ->
18661 let ?callStack = stack
18762 in