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

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

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

import           Control.Concurrent (killThread, threadDelay)
import qualified Control.Concurrent.Async as Async
import           Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,
                     readMVar, withMVar, modifyMVar_, tryTakeMVar)
import           Control.Concurrent.STM (atomically)
import qualified Control.Concurrent.STM.TBQueue as TBQ
import           Control.Exception (Exception, SomeException, catch, throwIO)
import           Control.Exception.Safe (throwM)
import           Control.Monad (void, forM_)
import           Control.Monad.IO.Class (liftIO)
import           Data.Aeson (FromJSON, ToJSON, encode)
import qualified Data.ByteString.Char8 as BS
import qualified Data.HashMap.Strict as HM
import           Data.Int (Int64)
import           Data.Maybe (fromMaybe)
import           Data.String (fromString)
import           Data.Text (Text, pack, stripPrefix)
import qualified Data.Text.IO as TIO
import           Data.Version (showVersion)

import           System.IO (stderr)
import qualified System.Metrics.Gauge as Gauge
import qualified System.Metrics.Label as Label
import           System.Remote.Monitoring (Server, forkServer,
                     getGauge, getLabel, serverThreadId)

import           Paths_iohk_monitoring (version)

import           Cardano.BM.Backend.ProcessQueue (processQueue)
import           Cardano.BM.Backend.Prometheus (spawnPrometheus)
import           Cardano.BM.Configuration (Configuration, getEKGBindAddr,
                     getPrometheusBindAddr, getTextOption, testSubTrace)
import           Cardano.BM.Data.Aggregated
import           Cardano.BM.Data.Backend
import           Cardano.BM.Data.Configuration (Endpoint (..))
import           Cardano.BM.Data.LogItem
import           Cardano.BM.Data.Severity
import           Cardano.BM.Data.Trace
import           Cardano.BM.Data.Tracer (Tracer (..), traceWith)
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
    EKGView a
be :: Cardano.BM.Backend.EKGView.EKGView a <- Configuration -> Trace IO a -> s a -> IO (EKGView 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 = EKGView a -> LogObject a -> IO ()
forall (t :: * -> *) a.
IsEffectuator t a =>
t a -> LogObject a -> IO ()
effectuate EKGView a
be, bUnrealize :: IO ()
bUnrealize = EKGView a -> IO ()
forall (t :: * -> *) a. IsBackend t a => t a -> IO ()
unrealize EKGView a
be })
               (EKGView a -> BackendKind
forall (t :: * -> *) a. IsBackend t a => t a -> BackendKind
bekind EKGView a
be)
\end{code}

\subsubsection{Structure of EKGView}\label{code:EKGView}\index{EKGView}
\begin{code}
type EKGViewMVar a = MVar (EKGViewInternal a)
newtype EKGView a = EKGView
    { EKGView a -> EKGViewMVar a
getEV :: EKGViewMVar a }

data EKGViewInternal a = EKGViewInternal
    { EKGViewInternal a -> Maybe (TBQueue (Maybe (LogObject a)))
evQueue              :: Maybe (TBQ.TBQueue (Maybe (LogObject a)))
    , EKGViewInternal a -> EKGViewMap Label
evLabels             :: !(EKGViewMap Label.Label)
    , EKGViewInternal a -> EKGViewMap Gauge
evGauges             :: !(EKGViewMap Gauge.Gauge)
    , EKGViewInternal a -> Maybe Server
evServer             :: Maybe Server
    , EKGViewInternal a -> Maybe (Async ())
evDispatch           :: Maybe (Async.Async ())
    , EKGViewInternal a -> Maybe (Async ())
evPrometheusDispatch :: Maybe (Async.Async ())
    }

\end{code}

\subsubsection{Relation from variable name to label handler}
We keep the label handlers for later update in a |HashMap|.
\begin{code}
type EKGViewMap a = HM.HashMap Text a

\end{code}

\subsubsection{Internal |Trace|}
This is an internal |Trace|, named "\#ekgview", which can be used to control
the messages that are being displayed by EKG.
\begin{code}
ekgTrace :: ToJSON a => EKGView a -> Configuration -> Trace IO a
ekgTrace :: EKGView a -> Configuration -> Trace IO a
ekgTrace EKGView a
ekg Configuration
_c =
    LoggerName -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. LoggerName -> Trace m a -> Trace m a
Trace.appendName LoggerName
"#ekgview" (Trace IO a -> Trace IO a) -> Trace IO a -> Trace IO a
forall a b. (a -> b) -> a -> b
$ EKGView a -> Trace IO a
forall a. ToJSON a => EKGView a -> Trace IO a
ekgTrace' EKGView a
ekg
  where
    ekgTrace' :: ToJSON a => EKGView a -> Trace IO a
    ekgTrace' :: EKGView a -> Trace IO a
ekgTrace' EKGView a
ekgview = ((LoggerName, LogObject a) -> IO ()) -> Trace IO a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (((LoggerName, LogObject a) -> IO ()) -> Trace IO a)
-> ((LoggerName, LogObject a) -> IO ()) -> Trace IO a
forall a b. (a -> b) -> a -> b
$ \(LoggerName
_ctx,lo :: LogObject a
lo@(LogObject LoggerName
outerloname LOMeta
_ LOContent a
_)) -> do
        let setLabel :: Text -> Text -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
            setLabel :: LoggerName
-> LoggerName
-> EKGViewInternal a
-> IO (Maybe (EKGViewInternal a))
setLabel LoggerName
name LoggerName
label ekg_i :: EKGViewInternal a
ekg_i@(EKGViewInternal Maybe (TBQueue (Maybe (LogObject a)))
_ EKGViewMap Label
labels EKGViewMap Gauge
_ Maybe Server
mserver Maybe (Async ())
_ Maybe (Async ())
_) =
                case (LoggerName -> EKGViewMap Label -> Maybe Label
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup LoggerName
name EKGViewMap Label
labels, Maybe Server
mserver) of
                    (Maybe Label
Nothing, Just Server
server) -> do
                        Label
ekghdl <- LoggerName -> Server -> IO Label
getLabel LoggerName
name Server
server
                        Label -> LoggerName -> IO ()
Label.set Label
ekghdl LoggerName
label
                        Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a)))
-> Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a))
forall a b. (a -> b) -> a -> b
$ EKGViewInternal a -> Maybe (EKGViewInternal a)
forall a. a -> Maybe a
Just (EKGViewInternal a -> Maybe (EKGViewInternal a))
-> EKGViewInternal a -> Maybe (EKGViewInternal a)
forall a b. (a -> b) -> a -> b
$ EKGViewInternal a
ekg_i { evLabels :: EKGViewMap Label
evLabels = LoggerName -> Label -> EKGViewMap Label -> EKGViewMap Label
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert LoggerName
name Label
ekghdl EKGViewMap Label
labels}
                    (Just Label
ekghdl, Maybe Server
_) -> do
                        Label -> LoggerName -> IO ()
Label.set Label
ekghdl LoggerName
label
                        Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (EKGViewInternal a)
forall a. Maybe a
Nothing
                    (Maybe Label
Nothing, Maybe Server
Nothing) ->
                        Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EKGViewInternal a)
forall a. Maybe a
Nothing
            setGauge :: Text -> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
            setGauge :: LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
setGauge LoggerName
name Int64
value ekg_i :: EKGViewInternal a
ekg_i@(EKGViewInternal Maybe (TBQueue (Maybe (LogObject a)))
_ EKGViewMap Label
_ EKGViewMap Gauge
gauges Maybe Server
mserver Maybe (Async ())
_ Maybe (Async ())
_) =
                case (LoggerName -> EKGViewMap Gauge -> Maybe Gauge
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup LoggerName
name EKGViewMap Gauge
gauges, Maybe Server
mserver) of
                    (Maybe Gauge
Nothing, Just Server
server) -> do
                        Gauge
ekghdl <- LoggerName -> Server -> IO Gauge
getGauge LoggerName
name Server
server
                        Gauge -> Int64 -> IO ()
Gauge.set Gauge
ekghdl Int64
value
                        Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a)))
-> Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a))
forall a b. (a -> b) -> a -> b
$ EKGViewInternal a -> Maybe (EKGViewInternal a)
forall a. a -> Maybe a
Just (EKGViewInternal a -> Maybe (EKGViewInternal a))
-> EKGViewInternal a -> Maybe (EKGViewInternal a)
forall a b. (a -> b) -> a -> b
$ EKGViewInternal a
ekg_i { evGauges :: EKGViewMap Gauge
evGauges = LoggerName -> Gauge -> EKGViewMap Gauge -> EKGViewMap Gauge
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert LoggerName
name Gauge
ekghdl EKGViewMap Gauge
gauges}
                    (Just Gauge
ekghdl, Maybe Server
_) -> do
                        Gauge -> Int64 -> IO ()
Gauge.set Gauge
ekghdl Int64
value
                        Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (EKGViewInternal a)
forall a. Maybe a
Nothing
                    (Maybe Gauge
Nothing, Maybe Server
Nothing) ->
                        Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (EKGViewInternal a)
forall a. Maybe a
Nothing

            update :: ToJSON a => LogObject a -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
            update :: LogObject a -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
update (LogObject LoggerName
loname LOMeta
_ (LogMessage a
logitem)) EKGViewInternal a
ekg_i =
                LoggerName
-> LoggerName
-> EKGViewInternal a
-> IO (Maybe (EKGViewInternal a))
forall a.
LoggerName
-> LoggerName
-> EKGViewInternal a
-> IO (Maybe (EKGViewInternal a))
setLabel LoggerName
loname (String -> LoggerName
pack (String -> LoggerName) -> String -> LoggerName
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
logitem) EKGViewInternal a
ekg_i
            update (LogObject LoggerName
loname LOMeta
_ (LogValue LoggerName
iname Measurable
value)) EKGViewInternal a
ekg_i =
                let logname :: LoggerName
logname = LoggerName
loname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
"." LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
iname
                in
                case Measurable
value of
                    (Microseconds Word64
x) -> LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
forall a.
LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
setGauge (LoggerName
logname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".us") (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x) EKGViewInternal a
ekg_i
                    (Nanoseconds  Word64
x) -> LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
forall a.
LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
setGauge (LoggerName
logname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".ns") (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x) EKGViewInternal a
ekg_i
                    (Seconds      Word64
x) -> LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
forall a.
LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
setGauge (LoggerName
logname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".s") (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x) EKGViewInternal a
ekg_i
                    (Bytes        Word64
x) -> LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
forall a.
LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
setGauge (LoggerName
logname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".B") (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x) EKGViewInternal a
ekg_i
                    (PureI        Integer
x) -> LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
forall a.
LoggerName
-> Int64 -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
setGauge (LoggerName
logname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".int") (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x) EKGViewInternal a
ekg_i
                    (PureD        Double
_) -> LoggerName
-> LoggerName
-> EKGViewInternal a
-> IO (Maybe (EKGViewInternal a))
forall a.
LoggerName
-> LoggerName
-> EKGViewInternal a
-> IO (Maybe (EKGViewInternal a))
setLabel (LoggerName
logname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".real") (String -> LoggerName
pack (String -> LoggerName) -> String -> LoggerName
forall a b. (a -> b) -> a -> b
$ Measurable -> String
forall a. Show a => a -> String
show Measurable
value) EKGViewInternal a
ekg_i
                    (Severity     Severity
_) -> LoggerName
-> LoggerName
-> EKGViewInternal a
-> IO (Maybe (EKGViewInternal a))
forall a.
LoggerName
-> LoggerName
-> EKGViewInternal a
-> IO (Maybe (EKGViewInternal a))
setLabel (LoggerName
logname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
".sev") (String -> LoggerName
pack (String -> LoggerName) -> String -> LoggerName
forall a b. (a -> b) -> a -> b
$ Measurable -> String
forall a. Show a => a -> String
show Measurable
value) EKGViewInternal a
ekg_i

            update LogObject a
_ EKGViewInternal a
_ = Maybe (EKGViewInternal a) -> IO (Maybe (EKGViewInternal a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (EKGViewInternal a)
forall a. Maybe a
Nothing

        MVar (EKGViewInternal a)
-> (EKGViewInternal a -> IO (EKGViewInternal a)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (EKGView a -> MVar (EKGViewInternal a)
forall a. EKGView a -> EKGViewMVar a
getEV EKGView a
ekgview) ((EKGViewInternal a -> IO (EKGViewInternal a)) -> IO ())
-> (EKGViewInternal a -> IO (EKGViewInternal a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \EKGViewInternal a
ekgup -> do
            let -- strip off some prefixes not necessary for display
                loname1 :: LoggerName
loname1 = LoggerName -> Maybe LoggerName -> LoggerName
forall a. a -> Maybe a -> a
fromMaybe LoggerName
outerloname (Maybe LoggerName -> LoggerName) -> Maybe LoggerName -> LoggerName
forall a b. (a -> b) -> a -> b
$ LoggerName -> LoggerName -> Maybe LoggerName
stripPrefix LoggerName
"#ekgview" LoggerName
outerloname
                loname :: LoggerName
loname = LoggerName -> Maybe LoggerName -> LoggerName
forall a. a -> Maybe a -> a
fromMaybe LoggerName
loname1 (Maybe LoggerName -> LoggerName) -> Maybe LoggerName -> LoggerName
forall a b. (a -> b) -> a -> b
$ LoggerName -> LoggerName -> Maybe LoggerName
stripPrefix LoggerName
"#aggregation" LoggerName
loname1
            Maybe (EKGViewInternal a)
upd <- LogObject a -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
forall a.
ToJSON a =>
LogObject a -> EKGViewInternal a -> IO (Maybe (EKGViewInternal a))
update LogObject a
lo{ loName :: LoggerName
loName = LoggerName
loname } EKGViewInternal a
ekgup
            case Maybe (EKGViewInternal a)
upd of
                Maybe (EKGViewInternal a)
Nothing     -> EKGViewInternal a -> IO (EKGViewInternal a)
forall (m :: * -> *) a. Monad m => a -> m a
return EKGViewInternal a
ekgup
                Just EKGViewInternal a
ekgup' -> EKGViewInternal a -> IO (EKGViewInternal a)
forall (m :: * -> *) a. Monad m => a -> m a
return EKGViewInternal a
ekgup'

\end{code}

\subsubsection{EKG view is an effectuator}\index{EKGView!instance of IsEffectuator}
Function |effectuate| is called to pass in a |LogObject| for display in EKG.
If the log item is an |AggregatedStats| message, then all its constituents are
put into the queue. In case the queue is full, all new items are dropped.
\begin{code}
instance IsEffectuator EKGView a where
    effectuate :: EKGView a -> LogObject a -> IO ()
effectuate EKGView a
ekgview LogObject a
item = do
        EKGViewInternal a
ekg <- MVar (EKGViewInternal a) -> IO (EKGViewInternal a)
forall a. MVar a -> IO a
readMVar (EKGView a -> MVar (EKGViewInternal a)
forall a. EKGView a -> EKGViewMVar a
getEV EKGView a
ekgview)
        case EKGViewInternal a -> Maybe (TBQueue (Maybe (LogObject a)))
forall a.
EKGViewInternal a -> Maybe (TBQueue (Maybe (LogObject a)))
evQueue EKGViewInternal a
ekg of
          Maybe (TBQueue (Maybe (LogObject a)))
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just TBQueue (Maybe (LogObject a))
queue -> TBQueue (Maybe (LogObject a)) -> IO ()
doEnqueue TBQueue (Maybe (LogObject a))
queue
     where
       doEnqueue :: TBQ.TBQueue (Maybe (LogObject a)) -> IO ()
       doEnqueue :: TBQueue (Maybe (LogObject a)) -> IO ()
doEnqueue TBQueue (Maybe (LogObject a))
queue =
         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 TBQueue (Maybe (LogObject a))
queue
                         if Bool
nocapacity
                         then EKGView a -> IO ()
forall (t :: * -> *) a. IsEffectuator t a => t a -> IO ()
handleOverflow EKGView a
ekgview
                         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 TBQueue (Maybe (LogObject a))
queue (LogObject a -> Maybe (LogObject a)
forall a. a -> Maybe a
Just LogObject a
a)
         in
         case LogObject a
item of
             (LogObject LoggerName
loname 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
loname 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
loname 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 :: EKGView a -> IO ()
handleOverflow EKGView a
_ = Handle -> LoggerName -> IO ()
TIO.hPutStrLn Handle
stderr LoggerName
"Notice: EKGViews's queue full, dropping log items!"

\end{code}

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

|EKGView| is an |IsBackend|
\begin{code}
instance (ToJSON a, FromJSON a) => IsBackend EKGView a where
    type BackendFailure EKGView = EKGBackendFailure

    bekind :: EKGView a -> BackendKind
bekind EKGView a
_ = BackendKind
EKGViewBK

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

    realizefrom :: Configuration -> Trace IO a -> s a -> IO (EKGView a)
realizefrom Configuration
config Trace IO a
sbtrace s a
_ = do
        MVar (EKGViewInternal a)
evref <- IO (MVar (EKGViewInternal a))
forall a. IO (MVar a)
newEmptyMVar
        let ekgview :: EKGView a
ekgview = MVar (EKGViewInternal a) -> EKGView a
forall a. EKGViewMVar a -> EKGView a
EKGView MVar (EKGViewInternal a)
evref
        Maybe Endpoint
evHostPort <- Configuration -> IO (Maybe Endpoint)
getEKGBindAddr Configuration
config
        (String
evHost, Port
evPort) <- case Maybe Endpoint
evHostPort of
          Just (Endpoint (String, Port)
ehp) -> (String, Port) -> IO (String, Port)
forall (m :: * -> *) a. Monad m => a -> m a
return (String, Port)
ehp
          Maybe Endpoint
Nothing -> String -> IO (String, Port)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"EKG Backend is enabled, but its host/port are undefined!"
        Server
ehdl <- (ByteString -> Port -> IO Server
forkServer (String -> ByteString
BS.pack String
evHost) Port
evPort
                 -- This unfortunate delay is to catch the async exception.
                 IO Server -> IO () -> IO Server
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Port -> IO ()
threadDelay Port
300000)
            IO Server -> (SomeException -> IO Server) -> IO Server
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (String -> EKGBackendFailure) -> SomeException -> IO Server
forall b. (String -> EKGBackendFailure) -> SomeException -> IO b
mkHandler String -> EKGBackendFailure
EKGServerStartupError
        Label
ekghdl <- LoggerName -> Server -> IO Label
getLabel LoggerName
"iohk-monitoring version" Server
ehdl
        Label -> LoggerName -> IO ()
Label.set Label
ekghdl (LoggerName -> IO ()) -> LoggerName -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> LoggerName
pack (Version -> String
showVersion Version
version)
        let ekgtrace :: Trace IO a
ekgtrace = EKGView a -> Configuration -> Trace IO a
forall a. ToJSON a => EKGView a -> Configuration -> Trace IO a
ekgTrace EKGView a
ekgview Configuration
config
#ifdef PERFORMANCE_TEST_QUEUE
        let qSize = 1000000
#else
        let qSize :: Natural
qSize = Natural
5120
#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
-> Trace IO a
-> IO (Async ())
forall a.
Configuration
-> TBQueue (Maybe (LogObject a))
-> Trace IO a
-> Trace IO a
-> IO (Async ())
spawnDispatcher Configuration
config TBQueue (Maybe (LogObject a))
queue Trace IO a
sbtrace Trace IO a
ekgtrace
          IO (Async ()) -> (SomeException -> IO (Async ())) -> IO (Async ())
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (String -> EKGBackendFailure) -> SomeException -> IO (Async ())
forall b. (String -> EKGBackendFailure) -> SomeException -> IO b
mkHandler String -> EKGBackendFailure
EKGDispatcherStartupError
        -- 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
        Maybe (String, Port)
prometheusBindAddr <- Configuration -> IO (Maybe (String, Port))
getPrometheusBindAddr Configuration
config
        Maybe LoggerName
prometheusOutput <- Configuration -> LoggerName -> IO (Maybe LoggerName)
getTextOption Configuration
config LoggerName
"prometheusOutput"
        Maybe (Async ())
prometheusDispatcher <-
                case Maybe (String, Port)
prometheusBindAddr of
                  Just (String
host, Port
port) -> do
                    Async ()
pd <- Server -> ByteString -> Port -> Maybe LoggerName -> IO (Async ())
spawnPrometheus Server
ehdl (String -> ByteString
forall a. IsString a => String -> a
fromString String
host) Port
port Maybe LoggerName
prometheusOutput
                      IO (Async ()) -> (SomeException -> IO (Async ())) -> IO (Async ())
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (String -> EKGBackendFailure) -> SomeException -> IO (Async ())
forall b. (String -> EKGBackendFailure) -> SomeException -> IO b
mkHandler String -> EKGBackendFailure
EKGPrometheusStartupError
                    Async () -> IO ()
forall a. Async a -> IO ()
Async.link Async ()
pd
                    Maybe (Async ()) -> IO (Maybe (Async ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Async () -> Maybe (Async ())
forall a. a -> Maybe a
Just Async ()
pd)
                  Maybe (String, Port)
Nothing ->
                    Maybe (Async ()) -> IO (Maybe (Async ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Async ())
forall a. Maybe a
Nothing
        MVar (EKGViewInternal a) -> EKGViewInternal a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (EKGViewInternal a)
evref (EKGViewInternal a -> IO ()) -> EKGViewInternal a -> IO ()
forall a b. (a -> b) -> a -> b
$ EKGViewInternal :: forall a.
Maybe (TBQueue (Maybe (LogObject a)))
-> EKGViewMap Label
-> EKGViewMap Gauge
-> Maybe Server
-> Maybe (Async ())
-> Maybe (Async ())
-> EKGViewInternal a
EKGViewInternal
                        { evLabels :: EKGViewMap Label
evLabels = EKGViewMap Label
forall k v. HashMap k v
HM.empty
                        , evGauges :: EKGViewMap Gauge
evGauges = EKGViewMap Gauge
forall k v. HashMap k v
HM.empty
                        , evServer :: Maybe Server
evServer = Server -> Maybe Server
forall a. a -> Maybe a
Just Server
ehdl
                        , evQueue :: Maybe (TBQueue (Maybe (LogObject a)))
evQueue = TBQueue (Maybe (LogObject a))
-> Maybe (TBQueue (Maybe (LogObject a)))
forall a. a -> Maybe a
Just TBQueue (Maybe (LogObject a))
queue
                        , evDispatch :: Maybe (Async ())
evDispatch = Async () -> Maybe (Async ())
forall a. a -> Maybe a
Just Async ()
dispatcher
                        , evPrometheusDispatch :: Maybe (Async ())
evPrometheusDispatch = Maybe (Async ())
prometheusDispatcher
                        }
        EKGView a -> IO (EKGView a)
forall (m :: * -> *) a. Monad m => a -> m a
return EKGView a
ekgview
      IO (EKGView a)
-> (EKGBackendFailure -> IO (EKGView a)) -> IO (EKGView a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` -- Try to catch specific errors first.
      Trace IO a -> EKGBackendFailure -> IO (EKGView a)
nullSetup Trace IO a
sbtrace
      IO (EKGView a)
-> (SomeException -> IO (EKGView a)) -> IO (EKGView a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` -- ..if that fails, catch everything.
      (Trace IO a -> EKGBackendFailure -> IO (EKGView a)
nullSetup Trace IO a
sbtrace (EKGBackendFailure -> IO (EKGView a))
-> (SomeException -> EKGBackendFailure)
-> SomeException
-> IO (EKGView a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EKGBackendFailure
EKGUnknownStartupError (String -> EKGBackendFailure)
-> (SomeException -> String) -> SomeException -> EKGBackendFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> String
forall a. Show a => a -> String
show :: SomeException -> String))
     where
       mkHandler
         :: (String -> EKGBackendFailure)
         -> SomeException
         -> IO b
       mkHandler :: (String -> EKGBackendFailure) -> SomeException -> IO b
mkHandler String -> EKGBackendFailure
ctor = EKGBackendFailure -> IO b
forall e a. Exception e => e -> IO a
throwIO (EKGBackendFailure -> IO b)
-> (SomeException -> EKGBackendFailure) -> SomeException -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EKGBackendFailure
ctor (String -> EKGBackendFailure)
-> (SomeException -> String) -> SomeException -> EKGBackendFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show

       nullSetup
         :: Trace IO a
         -> EKGBackendFailure
         -> IO (EKGView a)
       nullSetup :: Trace IO a -> EKGBackendFailure -> IO (EKGView a)
nullSetup Trace IO a
trace EKGBackendFailure
e = do
         LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Error PrivacyAnnotation
Public
         Trace IO a -> (LoggerName, LogObject a) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Trace IO a
trace ((LoggerName, LogObject a) -> IO ())
-> (LoggerName, LogObject a) -> IO ()
forall a b. (a -> b) -> a -> b
$ (LoggerName
"#ekgview.realizeFrom", LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject LoggerName
"#ekgview.realizeFrom" LOMeta
meta (LOContent a -> LogObject a) -> LOContent a -> LogObject a
forall a b. (a -> b) -> a -> b
$
           LoggerName -> LOContent a
forall a. LoggerName -> LOContent a
LogError (LoggerName -> LOContent a) -> LoggerName -> LOContent a
forall a b. (a -> b) -> a -> b
$ LoggerName
"EKGView backend disabled due to initialisation error: " LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> (String -> LoggerName
pack (String -> LoggerName) -> String -> LoggerName
forall a b. (a -> b) -> a -> b
$ EKGBackendFailure -> String
forall a. Show a => a -> String
show EKGBackendFailure
e))
         TBQueue Any
_ <- STM (TBQueue Any) -> IO (TBQueue Any)
forall a. STM a -> IO a
atomically (STM (TBQueue Any) -> IO (TBQueue Any))
-> STM (TBQueue Any) -> IO (TBQueue Any)
forall a b. (a -> b) -> a -> b
$ Natural -> STM (TBQueue Any)
forall a. Natural -> STM (TBQueue a)
TBQ.newTBQueue Natural
0
         MVar (EKGViewInternal a)
ref <- IO (MVar (EKGViewInternal a))
forall a. IO (MVar a)
newEmptyMVar
         MVar (EKGViewInternal a) -> EKGViewInternal a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (EKGViewInternal a)
ref (EKGViewInternal a -> IO ()) -> EKGViewInternal a -> IO ()
forall a b. (a -> b) -> a -> b
$ EKGViewInternal :: forall a.
Maybe (TBQueue (Maybe (LogObject a)))
-> EKGViewMap Label
-> EKGViewMap Gauge
-> Maybe Server
-> Maybe (Async ())
-> Maybe (Async ())
-> EKGViewInternal a
EKGViewInternal
           { evLabels :: EKGViewMap Label
evLabels = EKGViewMap Label
forall k v. HashMap k v
HM.empty
           , evGauges :: EKGViewMap Gauge
evGauges = EKGViewMap Gauge
forall k v. HashMap k v
HM.empty
           , evServer :: Maybe Server
evServer = Maybe Server
forall a. Maybe a
Nothing
           , evQueue :: Maybe (TBQueue (Maybe (LogObject a)))
evQueue = Maybe (TBQueue (Maybe (LogObject a)))
forall a. Maybe a
Nothing
           , evDispatch :: Maybe (Async ())
evDispatch = Maybe (Async ())
forall a. Maybe a
Nothing
           , evPrometheusDispatch :: Maybe (Async ())
evPrometheusDispatch = Maybe (Async ())
forall a. Maybe a
Nothing
           }
         EKGView a -> IO (EKGView a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EKGView a -> IO (EKGView a)) -> EKGView a -> IO (EKGView a)
forall a b. (a -> b) -> a -> b
$ MVar (EKGViewInternal a) -> EKGView a
forall a. EKGViewMVar a -> EKGView a
EKGView MVar (EKGViewInternal a)
ref

    unrealize :: EKGView a -> IO ()
unrealize EKGView a
ekgview = 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

        MVar (EKGViewInternal a) -> (EKGViewInternal a -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (EKGView a -> MVar (EKGViewInternal a)
forall a. EKGView a -> EKGViewMVar a
getEV EKGView a
ekgview) ((EKGViewInternal a -> IO ()) -> IO ())
-> (EKGViewInternal a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \EKGViewInternal a
ev -> do

            Maybe (TBQueue (Maybe (LogObject a)))
-> (TBQueue (Maybe (LogObject a)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (EKGViewInternal a -> Maybe (TBQueue (Maybe (LogObject a)))
forall a.
EKGViewInternal a -> Maybe (TBQueue (Maybe (LogObject a)))
evQueue EKGViewInternal a
ev) ((TBQueue (Maybe (LogObject a)) -> IO ()) -> IO ())
-> (TBQueue (Maybe (LogObject a)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                -- send terminating item to the queue
                \TBQueue (Maybe (LogObject a))
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

            Maybe (Async ()) -> (Async () -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (EKGViewInternal a -> Maybe (Async ())
forall a. EKGViewInternal a -> Maybe (Async ())
evDispatch EKGViewInternal a
ev) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                -- wait for the dispatcher to exit
                \Async ()
dispatcher -> do
                    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

            Maybe (Async ()) -> (Async () -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (EKGViewInternal a -> Maybe (Async ())
forall a. EKGViewInternal a -> Maybe (Async ())
evPrometheusDispatch EKGViewInternal a
ev) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel

        MVar (EKGViewInternal a) -> (EKGViewInternal a -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (EKGView a -> MVar (EKGViewInternal a)
forall a. EKGView a -> EKGViewMVar a
getEV EKGView a
ekgview) ((EKGViewInternal a -> IO ()) -> IO ())
-> (EKGViewInternal a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \EKGViewInternal a
ekg ->
            Maybe Server -> (Server -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (EKGViewInternal a -> Maybe Server
forall a. EKGViewInternal a -> Maybe Server
evServer EKGViewInternal a
ekg) ((Server -> IO ()) -> IO ()) -> (Server -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                \Server
server -> ThreadId -> IO ()
killThread (ThreadId -> IO ()) -> ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> ThreadId
serverThreadId Server
server

        MVar (EKGViewInternal a) -> IO ()
forall b. MVar b -> IO ()
clearMVar (MVar (EKGViewInternal a) -> IO ())
-> MVar (EKGViewInternal a) -> IO ()
forall a b. (a -> b) -> a -> b
$ EKGView a -> MVar (EKGViewInternal a)
forall a. EKGView a -> EKGViewMVar a
getEV EKGView a
ekgview

data EKGBackendFailure
  = EKGUnknownStartupError String
  | EKGServerStartupError String
  | EKGDispatcherStartupError String
  | EKGPrometheusStartupError String
  deriving Port -> EKGBackendFailure -> ShowS
[EKGBackendFailure] -> ShowS
EKGBackendFailure -> String
(Port -> EKGBackendFailure -> ShowS)
-> (EKGBackendFailure -> String)
-> ([EKGBackendFailure] -> ShowS)
-> Show EKGBackendFailure
forall a.
(Port -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EKGBackendFailure] -> ShowS
$cshowList :: [EKGBackendFailure] -> ShowS
show :: EKGBackendFailure -> String
$cshow :: EKGBackendFailure -> String
showsPrec :: Port -> EKGBackendFailure -> ShowS
$cshowsPrec :: Port -> EKGBackendFailure -> ShowS
Show

instance Exception EKGBackendFailure

\end{code}

\subsubsection{Asynchronously reading log items from the queue and their processing}
\begin{code}
spawnDispatcher :: Configuration
                -> TBQ.TBQueue (Maybe (LogObject a))
                -> Trace.Trace IO a
                -> Trace.Trace IO a
                -> IO (Async.Async ())
spawnDispatcher :: Configuration
-> TBQueue (Maybe (LogObject a))
-> Trace IO a
-> Trace IO a
-> IO (Async ())
spawnDispatcher Configuration
config TBQueue (Maybe (LogObject a))
evqueue Trace IO a
_sbtrace Trace IO a
ekgtrace =
    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 ()
qProc
  where
    {-@ lazy qProc @-}
    qProc :: IO ()
    qProc :: IO ()
qProc =
        TBQueue (Maybe (LogObject a))
-> (LogObject a -> () -> IO ()) -> () -> (() -> 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 -> () -> IO ()
processEKGView
            ()
            (\()
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    processEKGView :: LogObject a -> () -> IO ()
processEKGView obj :: LogObject a
obj@(LogObject LoggerName
loname0 LOMeta
_ LOContent a
_) ()
_ = do
        Maybe (LogObject a)
obj' <- Configuration
-> LoggerName -> LogObject a -> IO (Maybe (LogObject a))
forall a.
Configuration
-> LoggerName -> LogObject a -> IO (Maybe (LogObject a))
testSubTrace Configuration
config (LoggerName
"#ekgview." LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
loname0) LogObject a
obj
        case Maybe (LogObject a)
obj' of
            Just LogObject a
lo ->
                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
loname0 Trace IO a
ekgtrace
                in
                Trace IO a -> (LoggerName, LogObject a) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Trace IO a
trace (LoggerName
loname0, LogObject a
lo)
            Maybe (LogObject a)
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

\end{code}