\subsection{Cardano.BM.Backend.Graylog}
\label{code:Cardano.BM.Backend.Graylog}

%if style == newcode
\begin{code}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}

module Cardano.BM.Backend.Graylog
    (
      Graylog
    -- * Plugin
    , plugin
    ) where

import           Control.Concurrent (threadDelay)
import qualified Control.Concurrent.Async as Async
import           Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,
                     readMVar, withMVar, tryTakeMVar)
import           Control.Concurrent.STM (atomically)
import qualified Control.Concurrent.STM.TBQueue as TBQ
import           Control.Exception.Safe (SomeException, IOException, catch, throwM)
import           Control.Monad (void)
import           Control.Monad.IO.Class (liftIO)
import           Data.Aeson (FromJSON, ToJSON (..), Value, encode, object, (.=))
import qualified Data.ByteString.Lazy.Char8 as BS8
import           Data.Text (Text, pack)
import qualified Data.Text.IO as TIO
import qualified Network.Socket as Net
import           Network.Socket.ByteString (sendAll)
import           System.IO (stderr)
import           Text.Printf (printf)

import           Cardano.BM.Backend.ProcessQueue (processQueue)
import           Cardano.BM.Configuration (Configuration, getGraylogPort)
import           Cardano.BM.Data.Aggregated
import           Cardano.BM.Data.Backend
import           Cardano.BM.Data.LogItem
import           Cardano.BM.Data.Severity
import           Cardano.BM.Plugin
import qualified Cardano.BM.Trace as Trace

\end{code}
%endif

\subsubsection{Plugin definition}
\begin{code}
plugin :: (IsEffectuator s a, ToJSON a, FromJSON a)
       => Configuration -> Trace.Trace IO a -> s a -> IO (Plugin a)
plugin :: Configuration -> Trace IO a -> s a -> IO (Plugin a)
plugin Configuration
config Trace IO a
trace s a
sb = do
    Graylog a
be :: Cardano.BM.Backend.Graylog.Graylog a <- Configuration -> Trace IO a -> s a -> IO (Graylog a)
forall (t :: * -> *) a (s :: * -> *).
(IsBackend t a, IsEffectuator s a) =>
Configuration -> Trace IO a -> s a -> IO (t a)
realizefrom Configuration
config Trace IO a
trace s a
sb
    Plugin a -> IO (Plugin a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Plugin a -> IO (Plugin a)) -> Plugin a -> IO (Plugin a)
forall a b. (a -> b) -> a -> b
$ Backend a -> BackendKind -> Plugin a
forall a. Backend a -> BackendKind -> Plugin a
BackendPlugin
               (MkBackend :: forall a. (LogObject a -> IO ()) -> IO () -> Backend a
MkBackend { bEffectuate :: LogObject a -> IO ()
bEffectuate = Graylog a -> LogObject a -> IO ()
forall (t :: * -> *) a.
IsEffectuator t a =>
t a -> LogObject a -> IO ()
effectuate Graylog a
be, bUnrealize :: IO ()
bUnrealize = Graylog a -> IO ()
forall (t :: * -> *) a. IsBackend t a => t a -> IO ()
unrealize Graylog a
be })
               (Graylog a -> BackendKind
forall (t :: * -> *) a. IsBackend t a => t a -> BackendKind
bekind Graylog a
be)
\end{code}

\subsubsection{Structure of Graylog}\label{code:Graylog}\index{Graylog}
\begin{code}
type GraylogMVar a = MVar (GraylogInternal a)
newtype Graylog a = Graylog
    { Graylog a -> GraylogMVar a
getGL :: GraylogMVar a }

data GraylogInternal a = GraylogInternal
    { GraylogInternal a -> TBQueue (Maybe (LogObject a))
glQueue    :: TBQ.TBQueue (Maybe (LogObject a))
    , GraylogInternal a -> Async ()
glDispatch :: Async.Async ()
    }

\end{code}

\subsubsection{Graylog is an effectuator}\index{Graylog!instance of IsEffectuator}
Function |effectuate| is called to pass in a |LogObject| to forward to Graylog.
In case the queue is full, all new items are dropped.
\begin{code}
instance IsEffectuator Graylog a where
    effectuate :: Graylog a -> LogObject a -> IO ()
effectuate Graylog a
graylog LogObject a
item = do
        GraylogInternal a
gelf <- MVar (GraylogInternal a) -> IO (GraylogInternal a)
forall a. MVar a -> IO a
readMVar (Graylog a -> MVar (GraylogInternal a)
forall a. Graylog a -> GraylogMVar a
getGL Graylog a
graylog)
        let enqueue :: LogObject a -> IO ()
enqueue LogObject a
a = do
                        Bool
nocapacity <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (LogObject a)) -> STM Bool
forall a. TBQueue a -> STM Bool
TBQ.isFullTBQueue (GraylogInternal a -> TBQueue (Maybe (LogObject a))
forall a. GraylogInternal a -> TBQueue (Maybe (LogObject a))
glQueue GraylogInternal a
gelf)
                        if Bool
nocapacity
                        then Graylog a -> IO ()
forall (t :: * -> *) a. IsEffectuator t a => t a -> IO ()
handleOverflow Graylog a
graylog
                        else STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (LogObject a)) -> Maybe (LogObject a) -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQ.writeTBQueue (GraylogInternal a -> TBQueue (Maybe (LogObject a))
forall a. GraylogInternal a -> TBQueue (Maybe (LogObject a))
glQueue GraylogInternal a
gelf) (LogObject a -> Maybe (LogObject a)
forall a. a -> Maybe a
Just LogObject a
a)
        case LogObject a
item of
            (LogObject LoggerName
logname LOMeta
lometa (AggregatedMessage [(LoggerName, Aggregated)]
ags)) -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                let traceAgg :: [(Text,Aggregated)] -> IO ()
                    traceAgg :: [(LoggerName, Aggregated)] -> IO ()
traceAgg [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    traceAgg ((LoggerName
n,AggregatedEWMA EWMA
agewma):[(LoggerName, Aggregated)]
r) = do
                        LogObject a -> IO ()
enqueue (LogObject a -> IO ()) -> LogObject a -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject (LoggerName
logname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
"." LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
n) LOMeta
lometa (LoggerName -> Measurable -> LOContent a
forall a. LoggerName -> Measurable -> LOContent a
LogValue LoggerName
"avg" (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ EWMA -> Measurable
avg EWMA
agewma)
                        [(LoggerName, Aggregated)] -> IO ()
traceAgg [(LoggerName, Aggregated)]
r
                    traceAgg ((LoggerName
n,AggregatedStats Stats
stats):[(LoggerName, Aggregated)]
r) = do
                        let statsname :: LoggerName
statsname = LoggerName
logname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
"." LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
n
                            qbasestats :: BaseStats -> LoggerName -> IO ()
qbasestats BaseStats
s' LoggerName
nm = do
                                LogObject a -> IO ()
enqueue (LogObject a -> IO ()) -> LogObject a -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject LoggerName
nm LOMeta
lometa (LoggerName -> Measurable -> LOContent a
forall a. LoggerName -> Measurable -> LOContent a
LogValue LoggerName
"mean" (Double -> Measurable
PureD (Double -> Measurable) -> Double -> Measurable
forall a b. (a -> b) -> a -> b
$ BaseStats -> Double
meanOfStats BaseStats
s'))
                                LogObject a -> IO ()
enqueue (LogObject a -> IO ()) -> LogObject a -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject LoggerName
nm LOMeta
lometa (LoggerName -> Measurable -> LOContent a
forall a. LoggerName -> Measurable -> LOContent a
LogValue LoggerName
"min" (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ BaseStats -> Measurable
fmin BaseStats
s')
                                LogObject a -> IO ()
enqueue (LogObject a -> IO ()) -> LogObject a -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject LoggerName
nm LOMeta
lometa (LoggerName -> Measurable -> LOContent a
forall a. LoggerName -> Measurable -> LOContent a
LogValue LoggerName
"max" (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ BaseStats -> Measurable
fmax BaseStats
s')
                                LogObject a -> IO ()
enqueue (LogObject a -> IO ()) -> LogObject a -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject LoggerName
nm LOMeta
lometa (LoggerName -> Measurable -> LOContent a
forall a. LoggerName -> Measurable -> LOContent a
LogValue LoggerName
"count" (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ BaseStats -> Word64
fcount BaseStats
s')
                                LogObject a -> IO ()
enqueue (LogObject a -> IO ()) -> LogObject a -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject LoggerName
nm LOMeta
lometa (LoggerName -> Measurable -> LOContent a
forall a. LoggerName -> Measurable -> LOContent a
LogValue LoggerName
"stdev" (Double -> Measurable
PureD (Double -> Measurable) -> Double -> Measurable
forall a b. (a -> b) -> a -> b
$ BaseStats -> Double
stdevOfStats BaseStats
s'))
                        LogObject a -> IO ()
enqueue (LogObject a -> IO ()) -> LogObject a -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject LoggerName
statsname LOMeta
lometa (LoggerName -> Measurable -> LOContent a
forall a. LoggerName -> Measurable -> LOContent a
LogValue LoggerName
"last" (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Stats -> Measurable
flast Stats
stats)
                        BaseStats -> LoggerName -> IO ()
qbasestats (Stats -> BaseStats
fbasic Stats
stats) (LoggerName -> IO ()) -> LoggerName -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName
statsname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".basic"
                        BaseStats -> LoggerName -> IO ()
qbasestats (Stats -> BaseStats
fdelta Stats
stats) (LoggerName -> IO ()) -> LoggerName -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName
statsname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".delta"
                        BaseStats -> LoggerName -> IO ()
qbasestats (Stats -> BaseStats
ftimed Stats
stats) (LoggerName -> IO ()) -> LoggerName -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName
statsname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".timed"
                        [(LoggerName, Aggregated)] -> IO ()
traceAgg [(LoggerName, Aggregated)]
r
                [(LoggerName, Aggregated)] -> IO ()
traceAgg [(LoggerName, Aggregated)]
ags
            (LogObject LoggerName
_ LOMeta
_ (LogMessage a
_)) -> LogObject a -> IO ()
enqueue LogObject a
item
            (LogObject LoggerName
_ LOMeta
_ (LogValue LoggerName
_ Measurable
_)) -> LogObject a -> IO ()
enqueue LogObject a
item
            LogObject a
_                              -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    handleOverflow :: Graylog a -> IO ()
handleOverflow Graylog a
_ = Handle -> LoggerName -> IO ()
TIO.hPutStrLn Handle
stderr LoggerName
"Notice: Graylogs's queue full, dropping log items!"

\end{code}

\subsubsection{|Graylog| implements |Backend| functions}\index{Graylog!instance of IsBackend}

|Graylog| is an |IsBackend|
\begin{code}
instance (ToJSON a, FromJSON a) => IsBackend Graylog a where
    bekind :: Graylog a -> BackendKind
bekind Graylog a
_ = BackendKind
GraylogBK

    realize :: Configuration -> IO (Graylog a)
realize Configuration
_ = String -> IO (Graylog a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Graylog cannot be instantiated by 'realize'"

    realizefrom :: Configuration -> Trace IO a -> s a -> IO (Graylog a)
realizefrom Configuration
config Trace IO a
sbtrace s a
_ = do
        MVar (GraylogInternal a)
glref <- IO (MVar (GraylogInternal a))
forall a. IO (MVar a)
newEmptyMVar
        let graylog :: Graylog a
graylog = MVar (GraylogInternal a) -> Graylog a
forall a. GraylogMVar a -> Graylog a
Graylog MVar (GraylogInternal a)
glref
#ifdef PERFORMANCE_TEST_QUEUE
        let qSize = 1000000
#else
        let qSize :: Natural
qSize = Natural
1024
#endif
        TBQueue (Maybe (LogObject a))
queue <- STM (TBQueue (Maybe (LogObject a)))
-> IO (TBQueue (Maybe (LogObject a)))
forall a. STM a -> IO a
atomically (STM (TBQueue (Maybe (LogObject a)))
 -> IO (TBQueue (Maybe (LogObject a))))
-> STM (TBQueue (Maybe (LogObject a)))
-> IO (TBQueue (Maybe (LogObject a)))
forall a b. (a -> b) -> a -> b
$ Natural -> STM (TBQueue (Maybe (LogObject a)))
forall a. Natural -> STM (TBQueue a)
TBQ.newTBQueue Natural
qSize
        Async ()
dispatcher <- Configuration
-> TBQueue (Maybe (LogObject a)) -> Trace IO a -> IO (Async ())
forall a.
ToJSON a =>
Configuration
-> TBQueue (Maybe (LogObject a)) -> Trace IO a -> IO (Async ())
spawnDispatcher Configuration
config TBQueue (Maybe (LogObject a))
queue Trace IO a
sbtrace
        -- link the given Async to the current thread, such that if the Async
        -- raises an exception, that exception will be re-thrown in the current
        -- thread, wrapped in ExceptionInLinkedThread.
        Async () -> IO ()
forall a. Async a -> IO ()
Async.link Async ()
dispatcher
        MVar (GraylogInternal a) -> GraylogInternal a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (GraylogInternal a)
glref (GraylogInternal a -> IO ()) -> GraylogInternal a -> IO ()
forall a b. (a -> b) -> a -> b
$ GraylogInternal :: forall a.
TBQueue (Maybe (LogObject a)) -> Async () -> GraylogInternal a
GraylogInternal
                        { glQueue :: TBQueue (Maybe (LogObject a))
glQueue = TBQueue (Maybe (LogObject a))
queue
                        , glDispatch :: Async ()
glDispatch = Async ()
dispatcher
                        }
        Graylog a -> IO (Graylog a)
forall (m :: * -> *) a. Monad m => a -> m a
return Graylog a
graylog

    unrealize :: Graylog a -> IO ()
unrealize Graylog a
graylog = do
        let clearMVar :: MVar b -> IO ()
            clearMVar :: MVar b -> IO ()
clearMVar = IO (Maybe b) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe b) -> IO ())
-> (MVar b -> IO (Maybe b)) -> MVar b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar b -> IO (Maybe b)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar

        (Async ()
dispatcher, TBQueue (Maybe (LogObject a))
queue) <- MVar (GraylogInternal a)
-> (GraylogInternal a
    -> IO (Async (), TBQueue (Maybe (LogObject a))))
-> IO (Async (), TBQueue (Maybe (LogObject a)))
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Graylog a -> MVar (GraylogInternal a)
forall a. Graylog a -> GraylogMVar a
getGL Graylog a
graylog) (\GraylogInternal a
gelf ->
                                (Async (), TBQueue (Maybe (LogObject a)))
-> IO (Async (), TBQueue (Maybe (LogObject a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (GraylogInternal a -> Async ()
forall a. GraylogInternal a -> Async ()
glDispatch GraylogInternal a
gelf, GraylogInternal a -> TBQueue (Maybe (LogObject a))
forall a. GraylogInternal a -> TBQueue (Maybe (LogObject a))
glQueue GraylogInternal a
gelf))
        -- send terminating item to the queue
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (LogObject a)) -> Maybe (LogObject a) -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQ.writeTBQueue TBQueue (Maybe (LogObject a))
queue Maybe (LogObject a)
forall a. Maybe a
Nothing
        -- wait for the dispatcher to exit
        Either SomeException ()
res <- Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
Async.waitCatch Async ()
dispatcher
        (SomeException -> IO ())
-> (() -> IO ()) -> Either SomeException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException ()
res
        MVar (GraylogInternal a) -> IO ()
forall b. MVar b -> IO ()
clearMVar (MVar (GraylogInternal a) -> IO ())
-> MVar (GraylogInternal a) -> IO ()
forall a b. (a -> b) -> a -> b
$ Graylog a -> MVar (GraylogInternal a)
forall a. Graylog a -> GraylogMVar a
getGL Graylog a
graylog

\end{code}

\subsubsection{Asynchronously reading log items from the queue and their processing}
\begin{code}
spawnDispatcher :: forall a. ToJSON a
                => Configuration
                -> TBQ.TBQueue (Maybe (LogObject a))
                -> Trace.Trace IO a
                -> IO (Async.Async ())
spawnDispatcher :: Configuration
-> TBQueue (Maybe (LogObject a)) -> Trace IO a -> IO (Async ())
spawnDispatcher Configuration
config TBQueue (Maybe (LogObject a))
evqueue Trace IO a
sbtrace =
    let gltrace :: Trace IO a
gltrace = LoggerName -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. LoggerName -> Trace m a -> Trace m a
Trace.appendName LoggerName
"#graylog" Trace IO a
sbtrace
    in
    IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
Net.withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Trace IO a -> Maybe Socket -> IO ()
qProc Trace IO a
gltrace Maybe Socket
forall a. Maybe a
Nothing
  where
    {-@ lazy qProc @-}
    qProc :: Trace.Trace IO a -> Maybe Net.Socket -> IO ()
    qProc :: Trace IO a -> Maybe Socket -> IO ()
qProc Trace IO a
gltrace Maybe Socket
conn =
        TBQueue (Maybe (LogObject a))
-> (LogObject a
    -> (Trace IO a, Maybe Socket) -> IO (Trace IO a, Maybe Socket))
-> (Trace IO a, Maybe Socket)
-> ((Trace IO a, Maybe Socket) -> IO ())
-> IO ()
forall a b.
TBQueue (Maybe (LogObject a))
-> (LogObject a -> b -> IO b) -> b -> (b -> IO ()) -> IO ()
processQueue
            TBQueue (Maybe (LogObject a))
evqueue
            LogObject a
-> (Trace IO a, Maybe Socket) -> IO (Trace IO a, Maybe Socket)
processGraylog
            (Trace IO a
gltrace, Maybe Socket
conn)
            (\(Trace IO a
_, Maybe Socket
c) -> Maybe Socket -> IO ()
closeConn Maybe Socket
c)

    processGraylog :: LogObject a -> (Trace.Trace IO a, Maybe Net.Socket)
                   -> IO (Trace.Trace IO a, Maybe Net.Socket)
    processGraylog :: LogObject a
-> (Trace IO a, Maybe Socket) -> IO (Trace IO a, Maybe Socket)
processGraylog LogObject a
item (Trace IO a
gltrace, Maybe Socket
mConn) =
        case Maybe Socket
mConn of
            (Just Socket
conn) -> do
                Socket -> LogObject a -> IO ()
sendLO Socket
conn LogObject a
item
                    IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(IOException
e :: IOException) -> do
                        let trace' :: Trace IO a
trace' = LoggerName -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. LoggerName -> Trace m a -> Trace m a
Trace.appendName LoggerName
"sending" Trace IO a
gltrace
                        LOMeta
mle <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Error PrivacyAnnotation
Public
                        Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
Trace.traceNamedObject Trace IO a
trace' (LOMeta
mle, LoggerName -> LOContent a
forall a. LoggerName -> LOContent a
LogError (String -> LoggerName
pack (String -> LoggerName) -> String -> LoggerName
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
e))
                        Int -> IO ()
threadDelay Int
50000
                        IO (Trace IO a, Maybe Socket) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Trace IO a, Maybe Socket) -> IO ())
-> IO (Trace IO a, Maybe Socket) -> IO ()
forall a b. (a -> b) -> a -> b
$ LogObject a
-> (Trace IO a, Maybe Socket) -> IO (Trace IO a, Maybe Socket)
processGraylog LogObject a
item (Trace IO a
gltrace, Maybe Socket
mConn)
                (Trace IO a, Maybe Socket) -> IO (Trace IO a, Maybe Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace IO a
gltrace, Maybe Socket
mConn)
            Maybe Socket
Nothing     -> do
                Maybe Socket
mConn' <- Trace IO a -> IO (Maybe Socket)
tryConnect Trace IO a
gltrace
                LogObject a
-> (Trace IO a, Maybe Socket) -> IO (Trace IO a, Maybe Socket)
processGraylog LogObject a
item (Trace IO a
gltrace, Maybe Socket
mConn')

    sendLO :: Net.Socket -> LogObject a -> IO ()
    sendLO :: Socket -> LogObject a -> IO ()
sendLO Socket
conn LogObject a
obj =
        let msg :: ByteString
msg = ByteString -> ByteString
BS8.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ToJSON a => LogObject a -> ByteString
LogObject a -> ByteString
encodeMessage LogObject a
obj
        in Socket -> ByteString -> IO ()
sendAll Socket
conn ByteString
msg
    closeConn :: Maybe Net.Socket -> IO ()
    closeConn :: Maybe Socket -> IO ()
closeConn Maybe Socket
Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    closeConn (Just Socket
conn) = Socket -> IO ()
Net.close Socket
conn
    tryConnect :: Trace.Trace IO a -> IO (Maybe Net.Socket)
    tryConnect :: Trace IO a -> IO (Maybe Socket)
tryConnect Trace IO a
gltrace = do
        Int
port <- Configuration -> IO Int
getGraylogPort Configuration
config
        let hints :: AddrInfo
hints = AddrInfo
Net.defaultHints { addrSocketType :: SocketType
Net.addrSocketType = SocketType
Net.Datagram }
        (AddrInfo
addr:[AddrInfo]
_) <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Net.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
"127.0.0.1") (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
port)
        Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
Net.socket (AddrInfo -> Family
Net.addrFamily AddrInfo
addr) (AddrInfo -> SocketType
Net.addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
Net.addrProtocol AddrInfo
addr)
        Socket -> SockAddr -> IO ()
Net.connect Socket
sock (AddrInfo -> SockAddr
Net.addrAddress AddrInfo
addr) IO () -> IO (Maybe Socket) -> IO (Maybe Socket)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Socket -> IO (Maybe Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
sock)
            IO (Maybe Socket)
-> (SomeException -> IO (Maybe Socket)) -> IO (Maybe Socket)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
e :: SomeException) -> do
                let trace' :: Trace IO a
trace' = LoggerName -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. LoggerName -> Trace m a -> Trace m a
Trace.appendName LoggerName
"connecting" Trace IO a
gltrace
                LOMeta
mle <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Error PrivacyAnnotation
Public
                Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
Trace.traceNamedObject Trace IO a
trace' (LOMeta
mle, LoggerName -> LOContent a
forall a. LoggerName -> LOContent a
LogError (String -> LoggerName
pack (String -> LoggerName) -> String -> LoggerName
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
                Maybe Socket -> IO (Maybe Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Socket
forall a. Maybe a
Nothing

    encodeMessage :: ToJSON a => LogObject a -> BS8.ByteString
    encodeMessage :: LogObject a -> ByteString
encodeMessage LogObject a
lo = GelfItem -> ByteString
forall a. ToJSON a => a -> ByteString
encode (GelfItem -> ByteString) -> GelfItem -> ByteString
forall a b. (a -> b) -> a -> b
$ LogObject a -> GelfItem
forall a. ToJSON a => LogObject a -> GelfItem
mkGelfItem LogObject a
lo

\end{code}

\subsubsection{Gelf data structure}
GELF defines a data format of the message payload: \url{https://docs.graylog.org/en/3.0/pages/gelf.html}
\begin{code}
data GelfItem = GelfItem {
        GelfItem -> LoggerName
version :: !Text,
        GelfItem -> LoggerName
host :: !Text,
        GelfItem -> LoggerName
short_message :: !Text,
        GelfItem -> Value
full_message :: !Value,
        GelfItem -> Double
timestamp :: !Double,
        GelfItem -> Int
level :: !Int,
        GelfItem -> LoggerName
_tid :: !Text,
        GelfItem -> LoggerName
_privacy :: !Text
    }

mkGelfItem :: ToJSON a => LogObject a -> GelfItem
mkGelfItem :: LogObject a -> GelfItem
mkGelfItem (LogObject LoggerName
loname LOMeta
lometa LOContent a
locontent) = GelfItem :: LoggerName
-> LoggerName
-> LoggerName
-> Value
-> Double
-> Int
-> LoggerName
-> LoggerName
-> GelfItem
GelfItem {
        version :: LoggerName
version = LoggerName
"1.1",
        host :: LoggerName
host = LoggerName
"hostname",
        short_message :: LoggerName
short_message = LoggerName
loname,
        full_message :: Value
full_message = LOContent a -> Value
forall a. ToJSON a => a -> Value
toJSON LOContent a
locontent,
        timestamp :: Double
timestamp = (Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer -> Double) -> (Word64 -> Integer) -> Word64 -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Double) -> Word64 -> Double
forall a b. (a -> b) -> a -> b
$ UTCTime -> Word64
utc2ns (LOMeta -> UTCTime
tstamp LOMeta
lometa) :: Double) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000000000,
        level :: Int
level = Severity -> Int
forall a. Enum a => a -> Int
fromEnum (Bounded Severity => Severity
forall a. Bounded a => a
maxBound @Severity) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Severity -> Int
forall a. Enum a => a -> Int
fromEnum (LOMeta -> Severity
severity LOMeta
lometa),
        _tid :: LoggerName
_tid = LOMeta -> LoggerName
tid LOMeta
lometa,
        _privacy :: LoggerName
_privacy = String -> LoggerName
pack (String -> LoggerName) -> String -> LoggerName
forall a b. (a -> b) -> a -> b
$ PrivacyAnnotation -> String
forall a. Show a => a -> String
show (PrivacyAnnotation -> String) -> PrivacyAnnotation -> String
forall a b. (a -> b) -> a -> b
$ LOMeta -> PrivacyAnnotation
privacy LOMeta
lometa
    }

instance ToJSON GelfItem where
    toJSON :: GelfItem -> Value
toJSON GelfItem
gli = [Pair] -> Value
object [
            LoggerName
"version" LoggerName -> LoggerName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LoggerName -> v -> kv
.= GelfItem -> LoggerName
version GelfItem
gli,
            LoggerName
"host" LoggerName -> LoggerName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LoggerName -> v -> kv
.= GelfItem -> LoggerName
host GelfItem
gli,
            LoggerName
"short_message" LoggerName -> LoggerName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LoggerName -> v -> kv
.= GelfItem -> LoggerName
short_message GelfItem
gli,
            LoggerName
"full_message" LoggerName -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LoggerName -> v -> kv
.= GelfItem -> Value
full_message GelfItem
gli,
            LoggerName
"timestamp" LoggerName -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LoggerName -> v -> kv
.= (String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%0.3f" (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ GelfItem -> Double
timestamp GelfItem
gli :: String),
            LoggerName
"level" LoggerName -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LoggerName -> v -> kv
.= GelfItem -> Int
level GelfItem
gli,
            LoggerName
"_tid" LoggerName -> LoggerName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LoggerName -> v -> kv
.= GelfItem -> LoggerName
_tid GelfItem
gli,
            LoggerName
"_privacy" LoggerName -> LoggerName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => LoggerName -> v -> kv
.= GelfItem -> LoggerName
_privacy GelfItem
gli
        ]
\end{code}