@@ -2,61 +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
1813import Control.Has.Katip ()
1914import Control.Lens hiding ((.=))
2015import Control.Logger.Internal
21−import Control.Logger.Katip.Scribes.Reopenable
2216import Data.Aeson hiding (Error)
23−import Data.ByteString (ByteString)
24−import qualified Data.HashMap.Strict as HM
25−import Data.Proxy as P
2617import Data.Text (Text)
2718import qualified Data.Text as T
28−import qualified Data.Text.Encoding as T
2919import qualified Data.Text.Lazy.Builder as T.Builder
30−import Database.V5.Bloodhound
3120import Katip as K hiding (logMsg)
32−import Katip.Core (ItemFunc(..), LocJs(..), ProcessIDJs(..))
21+import Katip.Core (LocJs(..), ProcessIDJs(..))
3322import Katip.Monadic (KatipContextTState(..))
34−import Katip.Scribes.ElasticSearch
35−import Katip.Scribes.ElasticSearch.Internal as K
36−import Network.HTTP.Client
3723
3824
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−
6025logSeverityToKSeverity :: LogSeverity -> Severity
6126logSeverityToKSeverity = \case
6227 Debug -> DebugS
@@ -64,91 +29,6 @@ logSeverityToKSeverity = \case
6429 Warn -> WarningS
6530 Error -> ErrorS
6631
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"]
15232
15333katipIndexNameString :: Text
15434katipIndexNameString = "antorica-b2b-logs"
@@ -171,18 +51,12 @@ ourItemJson verb item = formatItem $
17151 , "loc" .= fmap LocJs _itemLoc
17252 ]
17353
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−
18054instance LogItem Object where
18155 payloadKeys V0 _ = SomeKeys []
18256 payloadKeys _ _ = AllKeys
18357
18458getKatipLogger :: KatipContextTState -> Logger
185−getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx)
59+getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx) mempty
18660 $ \ ctx stack s msg ->
18761 let ?callStack = stack
18862 in