module Control.Monad.Logger.Logstash (
runLogstashLoggerT,
stashJsonLine,
withLogstashLoggerT,
LogstashContext(..)
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TBMQueue
import Control.Exception (Handler)
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Trans.Reader
import Control.Retry
import Data.Aeson
import Data.Maybe
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import UnliftIO (MonadUnliftIO)
import Logstash hiding (stashJsonLine)
import qualified Logstash as L (stashJsonLine)
runLogstashLoggerT
:: LogstashContext ctx
=> ctx
-> RetryPolicyM IO
-> Integer
-> ( RetryStatus ->
(Loc, LogSource, LogLevel, LogStr) ->
ReaderT LogstashConnection IO ()
)
-> LoggingT m a
-> m a
runLogstashLoggerT :: ctx
-> RetryPolicyM IO
-> Integer
-> (RetryStatus
-> (Loc, LogSource, LogLevel, LogStr)
-> ReaderT LogstashConnection IO ())
-> LoggingT m a
-> m a
runLogstashLoggerT ctx
ctx RetryPolicyM IO
policy Integer
time RetryStatus
-> (Loc, LogSource, LogLevel, LogStr)
-> ReaderT LogstashConnection IO ()
codec LoggingT m a
log = LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT LoggingT m a
log ((Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall a b. (a -> b) -> a -> b
$
\Loc
logLoc LogSource
logSource LogLevel
logLevel LogStr
logStr -> ctx
-> RetryPolicyM IO
-> Integer
-> (RetryStatus -> ReaderT LogstashConnection IO ())
-> IO ()
forall ctx (m :: * -> *) a.
(LogstashContext ctx, MonadMask m, MonadUnliftIO m) =>
ctx
-> RetryPolicyM m
-> Integer
-> (RetryStatus -> ReaderT LogstashConnection m a)
-> m a
runLogstash ctx
ctx RetryPolicyM IO
policy Integer
time ((RetryStatus -> ReaderT LogstashConnection IO ()) -> IO ())
-> (RetryStatus -> ReaderT LogstashConnection IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
\RetryStatus
s -> RetryStatus
-> (Loc, LogSource, LogLevel, LogStr)
-> ReaderT LogstashConnection IO ()
codec RetryStatus
s (Loc
logLoc, LogSource
logSource, LogLevel
logLevel, LogStr
logStr)
withLogstashLoggerT
:: (LogstashContext ctx, MonadUnliftIO m)
=> LogstashQueueCfg ctx
-> ( RetryStatus ->
(Loc, LogSource, LogLevel, LogStr) ->
ReaderT LogstashConnection IO ()
)
-> [(Loc, LogSource, LogLevel, LogStr) -> Handler ()]
-> LoggingT m a
-> m a
withLogstashLoggerT :: LogstashQueueCfg ctx
-> (RetryStatus
-> (Loc, LogSource, LogLevel, LogStr)
-> ReaderT LogstashConnection IO ())
-> [(Loc, LogSource, LogLevel, LogStr) -> Handler ()]
-> LoggingT m a
-> m a
withLogstashLoggerT LogstashQueueCfg ctx
cfg RetryStatus
-> (Loc, LogSource, LogLevel, LogStr)
-> ReaderT LogstashConnection IO ()
dispatch [(Loc, LogSource, LogLevel, LogStr) -> Handler ()]
hs LoggingT m a
log = LogstashQueueCfg ctx
-> (RetryStatus
-> (Loc, LogSource, LogLevel, LogStr)
-> ReaderT LogstashConnection IO ())
-> [(Loc, LogSource, LogLevel, LogStr) -> Handler ()]
-> (TBMQueue (Loc, LogSource, LogLevel, LogStr) -> m a)
-> m a
forall ctx (m :: * -> *) item a.
(LogstashContext ctx, MonadUnliftIO m) =>
LogstashQueueCfg ctx
-> (RetryStatus -> item -> ReaderT LogstashConnection IO ())
-> [item -> Handler ()]
-> (TBMQueue item -> m a)
-> m a
withLogstashQueue LogstashQueueCfg ctx
cfg RetryStatus
-> (Loc, LogSource, LogLevel, LogStr)
-> ReaderT LogstashConnection IO ()
dispatch [(Loc, LogSource, LogLevel, LogStr) -> Handler ()]
hs ((TBMQueue (Loc, LogSource, LogLevel, LogStr) -> m a) -> m a)
-> (TBMQueue (Loc, LogSource, LogLevel, LogStr) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$
\TBMQueue (Loc, LogSource, LogLevel, LogStr)
queue -> LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT LoggingT m a
log ((Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall a b. (a -> b) -> a -> b
$
\Loc
logLoc LogSource
logSource LogLevel
logLevel LogStr
logStr -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
TBMQueue (Loc, LogSource, LogLevel, LogStr)
-> (Loc, LogSource, LogLevel, LogStr) -> STM ()
forall a. TBMQueue a -> a -> STM ()
writeTBMQueue TBMQueue (Loc, LogSource, LogLevel, LogStr)
queue (Loc
logLoc, LogSource
logSource, LogLevel
logLevel, LogStr
logStr)
stashJsonLine :: (Loc, LogSource, LogLevel, LogStr)
-> ReaderT LogstashConnection IO ()
stashJsonLine :: (Loc, LogSource, LogLevel, LogStr)
-> ReaderT LogstashConnection IO ()
stashJsonLine (Loc
logEntryLoc, LogSource
logEntrySource, LogLevel
logEntryLevel, LogStr
logEntryMessage) =
Value -> ReaderT LogstashConnection IO ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
a -> ReaderT LogstashConnection m ()
L.stashJsonLine (Value -> ReaderT LogstashConnection IO ())
-> Value -> ReaderT LogstashConnection IO ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
[ LogSource
"message" LogSource -> LogSource -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= ByteString -> LogSource
decodeUtf8 (LogStr -> ByteString
fromLogStr LogStr
logEntryMessage)
, LogSource
"log" LogSource -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= [Pair] -> Value
object
[ LogSource
"logger" LogSource -> LogSource -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= LogSource
logEntrySource
, LogSource
"level" LogSource -> LogSource -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= LogLevel -> LogSource
jsonLogLevel LogLevel
logEntryLevel
, LogSource
"origin" LogSource -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= [Pair] -> Value
object
[ LogSource
"file" LogSource -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= [Pair] -> Value
object
[ LogSource
"name" LogSource -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= Loc -> String
loc_filename Loc
logEntryLoc
, LogSource
"line" LogSource -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Loc -> (Int, Int)
loc_start Loc
logEntryLoc)
, LogSource
"package" LogSource -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= Loc -> String
loc_package Loc
logEntryLoc
, LogSource
"module" LogSource -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= Loc -> String
loc_module Loc
logEntryLoc
, LogSource
"start" LogSource -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= (Int, Int) -> Value
jsonCharPos (Loc -> (Int, Int)
loc_start Loc
logEntryLoc)
, LogSource
"end" LogSource -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= (Int, Int) -> Value
jsonCharPos (Loc -> (Int, Int)
loc_end Loc
logEntryLoc)
]
]
]
]
where jsonLogLevel :: LogLevel -> Text
jsonLogLevel :: LogLevel -> LogSource
jsonLogLevel LogLevel
LevelDebug = LogSource
"debug"
jsonLogLevel LogLevel
LevelInfo = LogSource
"info"
jsonLogLevel LogLevel
LevelWarn = LogSource
"warn"
jsonLogLevel LogLevel
LevelError = LogSource
"error"
jsonLogLevel (LevelOther LogSource
x) = LogSource
x
jsonCharPos :: (Int, Int) -> Value
jsonCharPos :: (Int, Int) -> Value
jsonCharPos (Int
line, Int
column) =
[Pair] -> Value
object [ LogSource
"line" LogSource -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= Int
line, LogSource
"column" LogSource -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LogSource -> v -> kv
.= Int
column ]