git.iko.soy/typeable/control-logger
on master help sign in
Extract logger into a separate package (#4758)

* Extract logger into a separate package * fix * fix seatmap build * haslex

commit7519f9fb4c8acbfca9ccc6c2c882a5aff0d1b85f authorYuras <shumovichy@gmail.com> dateWed 22 Jul 2020, 13:22 (6 years ago)
6 files changed+540
compare with master
unifiedsplit
Setup.hs+2 control-logger.cabal+45 src/Control/Logger.hs+212 src/Control/Logger/Internal.hs+73 src/Control/Logger/Katip.hs+189 src/Control/Logger/Katip/Scribes/Reopenable.hs+19
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
control-logger.cabalnew file+45
@@ -0,0 +1,45 @@
1+name: control-logger
2+version: 0.1.0.0
3+synopsis: Logger used by all projects
4+license: AllRightsReserved
5+build-type: Simple
6+cabal-version: >=1.10
7+
8+library
9+ hs-source-dirs: src
10+ ghc-options: -Wall
11+ if !impl(ghcjs)
12+ exposed-modules: Control.Logger
13+ Control.Logger.Katip
14+ Control.Logger.Katip.Scribes.Reopenable
15+ exposed-modules: Control.Logger.Internal
16+ build-depends: base
17+ , aeson
18+ , bloodhound
19+ , bytestring
20+ , control-has
21+ , deepseq
22+ , exceptions
23+ , fast-logger
24+ , http-client
25+ , lens
26+ , mtl
27+ , shakespeare
28+ , text
29+ , time
30+ , unordered-containers
31+ if !impl(ghcjs)
32+ build-depends: katip
33+ , katip-elasticsearch
34+ default-language: Haskell2010
35+ default-extensions: RankNTypes
36+ DataKinds
37+ FlexibleContexts
38+ FlexibleInstances
39+ LambdaCase
40+ OverloadedStrings
41+ ScopedTypeVariables
42+ DeriveGeneric
43+ ConstraintKinds
44+ RecordWildCards
45+ TypeSynonymInstances
src/Control/Logger.hsnew file+212
@@ -0,0 +1,212 @@
1+
2+module Control.Logger
3+ ( Logger
4+ , loggerContext
5+ , logMsg
6+ , logMsgWith
7+ , logInfo
8+ , logDebug
9+ , logWarn
10+ , logError
11+ , logInfoWith
12+ , logDebugWith
13+ , logWarnWith
14+ , logErrorWith
15+ , tryLogError
16+ , tryJustLog
17+ , tryJustWarn
18+ , logExceptions
19+ , LogSeverity(..)
20+ , oneoffLog
21+ , LoggingMonad
22+ , LogSource
23+ , fileLogger
24+ , silentLogger
25+ , flushingFastFunc
26+ , flushingStderrLogger
27+ , stderrLogger
28+ , stdoutLogger
29+ , defaultFastFunc
30+ , compactCallStack
31+ , st
32+ , ToObject(..)
33+ ) where
34+
35+import Control.Has
36+import Control.Logger.Internal
37+import Control.Monad.Catch
38+import qualified Data.List as List
39+import Data.Text (Text)
40+import qualified Data.Text as Text
41+import Data.Time
42+import GHC.Stack
43+import Katip (ToObject(..))
44+import System.Log.FastLogger
45+import Text.Shakespeare.Text (st)
46+
47+logError
48+ :: (LoggingMonad r m)
49+ => Text
50+ -> m ()
51+logError = withFrozenCallStack . logMsg Error
52+
53+logDebug
54+ :: (LoggingMonad r m)
55+ => Text
56+ -> m ()
57+logDebug = withFrozenCallStack . logMsg Debug
58+
59+logInfo
60+ :: (LoggingMonad r m)
61+ => Text
62+ -> m ()
63+logInfo = withFrozenCallStack . logMsg Info
64+
65+logWarn
66+ :: (LoggingMonad r m)
67+ => Text
68+ -> m ()
69+logWarn = withFrozenCallStack . logMsg Warn
70+
71+logInfoWith
72+ :: (MonadIO m, HasCallStack)
73+ => Logger
74+ -> Text
75+ -> m ()
76+logInfoWith logger = withFrozenCallStack . logMsgWith logger Info
77+
78+logDebugWith
79+ :: (MonadIO m, HasCallStack)
80+ => Logger
81+ -> Text
82+ -> m ()
83+logDebugWith logger = withFrozenCallStack . logMsgWith logger Debug
84+
85+logWarnWith
86+ :: (MonadIO m, HasCallStack)
87+ => Logger
88+ -> Text
89+ -> m ()
90+logWarnWith logger = withFrozenCallStack . logMsgWith logger Warn
91+
92+logErrorWith
93+ :: (MonadIO m, HasCallStack)
94+ => Logger
95+ -> Text
96+ -> m ()
97+logErrorWith logger = withFrozenCallStack . logMsgWith logger Error
98+
99+-- | Log exceptions occured in computation and just ignore them.
100+tryLogError
101+ :: (MonadIO m, MonadCatch m, Has Logger r, MonadReader r m)
102+ => m ()
103+ -> m ()
104+tryLogError a = try a >>= \case
105+ Left (e :: SomeException) -> logError . Text.pack $ show e
106+ Right x -> return x
107+
108+tryJustLog
109+ :: (MonadIO m, MonadCatch m, Has Logger r, MonadReader r m)
110+ => m a
111+ -> (Text -> Text)
112+ -- ^ generates error message from exception type + exception text
113+ -> m (Maybe a)
114+tryJustLog action genMsg = do
115+ let
116+ logAll :: SomeException -> Maybe SomeException
117+ logAll = Just
118+ errorHandler (SomeException e) =
119+ logError (genMsg $ Text.pack $ show e) >> pure Nothing
120+ catchJust logAll (Just <$> action) errorHandler
121+
122+tryJustWarn
123+ :: (MonadIO m, Has Logger r, MonadCatch m, MonadReader r m)
124+ => m a
125+ -> (Text -> Text)
126+ -- ^ generates warning message from exception type + exception text
127+ -> m (Maybe a)
128+tryJustWarn action genMsg = do
129+ let
130+ logAll :: SomeException -> Maybe SomeException
131+ logAll = Just
132+ errorHandler (SomeException e) =
133+ logWarn (genMsg $ Text.pack $ show e) >> pure Nothing
134+ catchJust logAll (Just <$> action) errorHandler
135+
136+logExceptions :: (MonadCatch m, MonadThrow m, LoggingMonad r m) => m a -> m a
137+logExceptions ma = catch ma $ \e -> do
138+ logError $ (Text.pack . show) (e :: SomeException)
139+ throwM e
140+
141+oneoffLog :: MonadIO m => Logger -> LogSeverity -> Text -> m ()
142+oneoffLog logger s t = flip runReaderT logger $ logMsg s t
143+
144+fileLogger :: MonadIO m => FilePath -> m Logger
145+fileLogger fp = fastFunc <$> liftIO (newFileLoggerSet defaultBufSize fp)
146+
147+silentLogger :: Logger
148+silentLogger = Logger mempty (\_ _ _ _ -> return ())
149+
150+-- | Logger which flushes buffer after each message. This is useful with
151+-- stderrLogger.
152+flushingFastFunc
153+ :: LogSeverity -> LoggerSet -> Logger
154+flushingFastFunc minLogLevel loggerSet =
155+ Logger mempty $ \_ stack logLevel msg ->
156+ when (logLevel >= minLogLevel) $ do
157+ ts <- getCurrentTime
158+ pushLogStr loggerSet
159+ $ formatLogStr ts stack mempty logLevel (toLogStr msg)
160+ flushLogStr loggerSet
161+
162+-- | Used only in tests.
163+stderrLogger :: MonadIO m => LogSource -> m Logger
164+stderrLogger loc =
165+ defaultFastFunc loc Debug <$> liftIO (newStderrLoggerSet defaultBufSize)
166+
167+stdoutLogger :: MonadIO m => LogSource -> m Logger
168+stdoutLogger loc =
169+ defaultFastFunc loc Debug <$> liftIO (newStdoutLoggerSet defaultBufSize)
170+
171+-- | same as 'stderrLogger' but flushes buffer after each line.
172+flushingStderrLogger :: MonadIO m => m Logger
173+flushingStderrLogger =
174+ flushingFastFunc Debug <$> liftIO (newStderrLoggerSet defaultBufSize)
175+
176+-- | Make our outdated 'Logger' of fast-logger's 'LoggerSet'
177+fastFunc :: LoggerSet -> Logger
178+fastFunc loggerSet =
179+ Logger mempty $ \_ _ _ msg -> pushLogStr loggerSet $ toLogStr msg
180+
181+type LogSource = Text
182+
183+-- | Default logger tests and same things.
184+defaultFastFunc :: LogSource -> LogSeverity -> LoggerSet -> Logger
185+defaultFastFunc loc minLogLevel loggerSet =
186+ Logger mempty $ \_ stack s msg -> when (s >= minLogLevel) $ do
187+ ts <- getCurrentTime
188+ pushLogStr loggerSet $ formatLogStr ts stack loc s (toLogStr msg)
189+
190+-- | Prepends to 'LogStr' string with "[time][log-level]". Used for
191+-- text logs only
192+formatLogStr
193+ :: UTCTime -> CallStack -> LogSource -> LogSeverity -> LogStr -> LogStr
194+formatLogStr ts _ src level msg =
195+ "[" <> tsStr <> "][" <> levelStr <> srcStr <> "] " <> msg <> "\n"
196+ where
197+ srcStr = if Text.null src then mempty else "#" <> toLogStr src
198+ -- TODO: time-1.8 support padding: %6Q (microseconds)
199+ tsStr = toLogStr $ formatTime defaultTimeLocale "%FT%T%Q" ts
200+ levelStr = case level of
201+ Debug -> "DEBUG"
202+ Info -> "INFO"
203+ Warn -> "WARN"
204+ Error -> "ERROR"
205+
206+compactCallStack :: CallStack -> String
207+compactCallStack =
208+ unwords
209+ . List.intersperse "->"
210+ . map (\(f, l) -> f <> " (" <> compactLoc l <> ")")
211+ . getCallStack
212+ where compactLoc loc = srcLocFile loc <> ":" <> show (srcLocStartLine loc)
src/Control/Logger/Internal.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+
3+module Control.Logger.Internal
4+ ( Logger(..)
5+ , loggerContext
6+ , loggerAction
7+ , runLogger
8+ , LogSeverity(..)
9+ , LoggingMonad
10+ , logMsg
11+ , logMsgWith
12+ ) where
13+
14+import Control.Has
15+import Control.Lens
16+import Control.DeepSeq
17+import Data.Aeson (ToJSON, FromJSON, Object)
18+import Data.Text (Text)
19+import GHC.Generics (Generic)
20+import GHC.Stack
21+
22+
23+data LogSeverity
24+ = Debug
25+ | Info
26+ | Warn
27+ | Error
28+ deriving (Eq, Show, Ord, Generic)
29+
30+instance ToJSON LogSeverity
31+instance FromJSON LogSeverity
32+
33+data Logger
34+ = Logger
35+ { _loggerContext :: Object
36+ , _loggerAction :: Object -> CallStack -> LogSeverity -> Text -> IO ()
37+ } deriving Generic
38+
39+instance NFData Logger
40+
41+makeLenses ''Logger
42+
43+instance Semigroup Logger where
44+ (Logger ctx1 l1) <> (Logger ctx2 l2) = Logger ctx'
45+ $ \ctx stack s t -> l1 ctx stack s t >> l2 ctx stack s t
46+ where ctx' = ctx1 <> ctx2
47+
48+instance Monoid Logger where
49+ mempty = Logger mempty $ \_ _ _ _ -> pure ()
50+
51+type LoggingMonad r m =
52+ (MonadReader r m, Has Logger r, MonadIO m, HasCallStack)
53+
54+logMsg
55+ :: (LoggingMonad r m)
56+ => LogSeverity
57+ -> Text
58+ -> m ()
59+logMsg s t = withFrozenCallStack $ do
60+ logger <- view part
61+ logMsgWith logger s t
62+
63+logMsgWith
64+ :: (MonadIO m, HasCallStack)
65+ => Logger
66+ -> LogSeverity
67+ -> Text
68+ -> m ()
69+logMsgWith logger s t =
70+ liftIO $ runLogger logger callStack s t
71+
72+runLogger :: Logger -> CallStack -> LogSeverity -> Text -> IO ()
73+runLogger (Logger ctx logger) = logger ctx
src/Control/Logger/Katip.hsnew file+189
@@ -0,0 +1,189 @@
1+{-# LANGUAGE ImplicitParams #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
4+module Control.Logger.Katip
5+ ( ElasticServer(..)
6+ , logSeverityToKSeverity
7+ , registerElastic
8+ , maybeElastic
9+ , KatipContextTState(..)
10+ , getKatipLogger
11+ , ourFormatter
12+ , ourMapping
13+ , katipIndexNameString
14+ , reopenableFileLog
15+ ) where
16+
17+import Control.EnvT
18+import Control.Lens hiding ((.=))
19+import Control.Logger.Internal
20+import Control.Logger.Katip.Scribes.Reopenable
21+import Data.Aeson hiding (Error)
22+import Data.ByteString (ByteString)
23+import qualified Data.HashMap.Strict as HM
24+import Data.Proxy as P
25+import Data.Text (Text)
26+import qualified Data.Text as T
27+import qualified Data.Text.Encoding as T
28+import qualified Data.Text.Lazy.Builder as T.Builder
29+import Database.V5.Bloodhound
30+import Katip as K hiding (logMsg)
31+import Katip.Core (ItemFunc(..), LocJs(..), ProcessIDJs(..))
32+import Katip.Monadic (KatipContextTState(..))
33+import Katip.Scribes.ElasticSearch
34+import Katip.Scribes.ElasticSearch.Internal as K
35+import Network.HTTP.Client
36+
37+
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+
59+logSeverityToKSeverity :: LogSeverity -> Severity
60+logSeverityToKSeverity = \case
61+ Debug -> DebugS
62+ Info -> InfoS
63+ Warn -> WarningS
64+ Error -> ErrorS
65+
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"]
151+
152+katipIndexNameString :: Text
153+katipIndexNameString = "antorica-b2b-logs"
154+
155+ourItemJson :: LogItem a => Verbosity -> Item a -> Value
156+ourItemJson verb item = formatItem $
157+ item & itemPayload %~ payloadObject verb
158+ where
159+ formatItem Item{..} = object
160+ [ "app" .= T.intercalate "." (unNamespace _itemApp)
161+ , "env" .= _itemEnv
162+ , "sev" .= _itemSeverity
163+ , "thread" .= getThreadIdText _itemThread
164+ , "host" .= _itemHost
165+ , "pid" .= ProcessIDJs _itemProcess
166+ , "data" .= _itemPayload
167+ , "msg" .= T.Builder.toLazyText (unLogStr _itemMessage)
168+ , "at" .= _itemTime
169+ , "ns" .= T.intercalate "." (unNamespace _itemNamespace)
170+ , "loc" .= fmap LocJs _itemLoc
171+ ]
172+
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+
179+instance LogItem Object where
180+ payloadKeys V0 _ = SomeKeys []
181+ payloadKeys _ _ = AllKeys
182+
183+getKatipLogger :: KatipContextTState -> Logger
184+getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx)
185+ $ \ ctx stack s msg ->
186+ let ?callStack = stack
187+ in
188+ flip runEnvT katipCtx {ltsContext = liftPayload ctx}
189+ $ logLocM (logSeverityToKSeverity s) (logStr msg)
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)