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

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

module Cardano.BM.Backend.Switchboard
    (
      Switchboard
    , mainTraceConditionally
    , readLogBuffer
    , effectuate
    , realize
    , unrealize
    , waitForTermination
    -- * integrate external backend
    , addUserDefinedBackend
    , addExternalBackend
    , addExternalScribe
    -- * testing
    --, realizeSwitchboard
    --, unrealizeSwitchboard
    ) where

import qualified Control.Concurrent.Async as Async
import           Control.Concurrent.MVar (MVar, newEmptyMVar, modifyMVar_,
                     putMVar, readMVar, tryReadMVar, withMVar)
import           Control.Concurrent.STM (atomically, retry)
import qualified Control.Concurrent.STM.TBQueue as TBQ
import           Control.Exception.Safe (throwM, fromException)
import           Control.Exception (SomeException(..))
import           Control.Monad (forM_, when)
import           Data.Aeson (FromJSON, ToJSON)
import           Data.Maybe (isJust)
import           Data.Text (Text)
import qualified Data.Text.IO as TIO
import           GHC.IO.Exception (BlockedIndefinitelyOnSTM)
import qualified Katip as K
import           System.IO (stderr)

import           Cardano.BM.Configuration (Configuration)
import qualified Cardano.BM.Configuration as Config
import           Cardano.BM.Configuration.Model (getBackends,
                     getSetupBackends, setSeverity, setMinSeverity)
import           Cardano.BM.Data.Backend
import           Cardano.BM.Data.LogItem
import           Cardano.BM.Data.Severity
import           Cardano.BM.Data.SubTrace (SubTrace (..))
import           Cardano.BM.Data.Trace (Trace)
import           Cardano.BM.Data.Tracer (Tracer (..))
import qualified Cardano.BM.Backend.Log
import qualified Cardano.BM.Backend.LogBuffer

\end{code}
%endif

\subsubsection{Switchboard}\label{code:Switchboard}\index{Switchboard}

We are using an |MVar| because we spawn a set of backends that may try to send messages to
the switchboard before it is completely setup.

\begin{code}

type SwitchboardMVar a = MVar (SwitchboardInternal a)

newtype Switchboard a = Switchboard
    { Switchboard a -> SwitchboardMVar a
getSB :: SwitchboardMVar a 
    }

data SwitchboardInternal a = SwitchboardInternal
    { SwitchboardInternal a -> TBQueue (LogObject a)
sbQueue     :: TBQ.TBQueue (LogObject a)
    , SwitchboardInternal a -> Async ()
sbDispatch  :: Async.Async ()
    , SwitchboardInternal a -> LogBuffer a
sbLogBuffer :: !(Cardano.BM.Backend.LogBuffer.LogBuffer a)
    , SwitchboardInternal a -> Log a
sbLogBE     :: !(Cardano.BM.Backend.Log.Log a)
    , SwitchboardInternal a -> NamedBackends a
sbBackends  :: NamedBackends a
    , SwitchboardInternal a -> SwitchboardStatus
sbRunning   :: !SwitchboardStatus
    }

type NamedBackends a = [(BackendKind, Backend a)]

data SwitchboardStatus
    = SwitchboardRunning
    | SwitchboardStopped
    deriving (SwitchboardStatus -> SwitchboardStatus -> Bool
(SwitchboardStatus -> SwitchboardStatus -> Bool)
-> (SwitchboardStatus -> SwitchboardStatus -> Bool)
-> Eq SwitchboardStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SwitchboardStatus -> SwitchboardStatus -> Bool
$c/= :: SwitchboardStatus -> SwitchboardStatus -> Bool
== :: SwitchboardStatus -> SwitchboardStatus -> Bool
$c== :: SwitchboardStatus -> SwitchboardStatus -> Bool
Eq, Int -> SwitchboardStatus -> ShowS
[SwitchboardStatus] -> ShowS
SwitchboardStatus -> String
(Int -> SwitchboardStatus -> ShowS)
-> (SwitchboardStatus -> String)
-> ([SwitchboardStatus] -> ShowS)
-> Show SwitchboardStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SwitchboardStatus] -> ShowS
$cshowList :: [SwitchboardStatus] -> ShowS
show :: SwitchboardStatus -> String
$cshow :: SwitchboardStatus -> String
showsPrec :: Int -> SwitchboardStatus -> ShowS
$cshowsPrec :: Int -> SwitchboardStatus -> ShowS
Show)

\end{code}

\subsubsection{Trace that forwards to the |Switchboard|}
\label{code:mainTraceConditionally}\index{mainTraceConditionally}
Every |Trace| ends in the |Switchboard| which then takes care of
dispatching the messages to the selected backends.
\\
This |Tracer| will forward all messages unconditionally to the |Switchboard|.
(currently disabled)
\begin{spec}
mainTrace :: IsEffectuator eff a => eff a -> Tracer IO (LogObject a)
mainTrace = Tracer . effectuate

\end{spec}

This |Tracer| will apply to every message the severity filter as defined in the |Configuration|.
\begin{code}
mainTraceConditionally :: IsEffectuator eff a => Configuration -> eff a -> Trace IO a
mainTraceConditionally :: Configuration -> eff a -> Trace IO a
mainTraceConditionally Configuration
config eff a
eff = ((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
ctxname,LogObject a
item) -> do
    Maybe (LogObject a)
mayItem <- Configuration
-> LoggerName -> LogObject a -> IO (Maybe (LogObject a))
forall a.
Configuration
-> LoggerName -> LogObject a -> IO (Maybe (LogObject a))
Config.testSubTrace Configuration
config LoggerName
ctxname LogObject a
item
    case Maybe (LogObject a)
mayItem of
        Just itemF :: LogObject a
itemF@(LogObject LoggerName
_loname LOMeta
meta LOContent a
_) -> do
            Bool
passSevFilter <- Configuration -> LoggerName -> LOMeta -> IO Bool
Config.testSeverity Configuration
config LoggerName
ctxname LOMeta
meta
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
passSevFilter (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                -- pass to backend and insert name
                eff a -> LogObject a -> IO ()
forall (t :: * -> *) a.
IsEffectuator t a =>
t a -> LogObject a -> IO ()
effectuate eff a
eff LogObject a
itemF { loName :: LoggerName
loName = LoggerName
ctxname }
        Maybe (LogObject a)
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

\end{code}

\subsubsection{Process incoming messages}\index{Switchboard!instance of IsEffectuator}
Incoming messages are put into the queue, and then processed by the dispatcher.
The switchboard will never block when processing incoming messages
("eager receiver").
\newline
The queue is initialized and the message dispatcher launched.

\begin{code}
instance IsEffectuator Switchboard a where
    effectuate :: Switchboard a -> LogObject a -> IO ()
effectuate Switchboard a
switchboard LogObject a
item = do
        let writequeue :: TBQ.TBQueue (LogObject a) -> LogObject a -> IO ()
            writequeue :: TBQueue (LogObject a) -> LogObject a -> IO ()
writequeue TBQueue (LogObject a)
q LogObject a
i = 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 (LogObject a) -> STM Bool
forall a. TBQueue a -> STM Bool
TBQ.isFullTBQueue TBQueue (LogObject a)
q
                    if Bool
nocapacity
                    then Switchboard a -> IO ()
forall (t :: * -> *) a. IsEffectuator t a => t a -> IO ()
handleOverflow Switchboard a
switchboard
                    else STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (LogObject a) -> LogObject a -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQ.writeTBQueue TBQueue (LogObject a)
q LogObject a
i

        SwitchboardInternal a
sb <- MVar (SwitchboardInternal a) -> IO (SwitchboardInternal a)
forall a. MVar a -> IO a
readMVar (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard)

        if (SwitchboardInternal a -> SwitchboardStatus
forall a. SwitchboardInternal a -> SwitchboardStatus
sbRunning SwitchboardInternal a
sb) SwitchboardStatus -> SwitchboardStatus -> Bool
forall a. Eq a => a -> a -> Bool
== SwitchboardStatus
SwitchboardRunning
            then TBQueue (LogObject a) -> LogObject a -> IO ()
writequeue (SwitchboardInternal a -> TBQueue (LogObject a)
forall a. SwitchboardInternal a -> TBQueue (LogObject a)
sbQueue SwitchboardInternal a
sb) LogObject a
item
            else Handle -> LoggerName -> IO ()
TIO.hPutStrLn Handle
stderr LoggerName
"Error: Switchboard is not running, dropping log items!"
        
    handleOverflow :: Switchboard a -> IO ()
handleOverflow Switchboard a
_ = Handle -> LoggerName -> IO ()
TIO.hPutStrLn Handle
stderr LoggerName
"Error: Switchboard's queue full, dropping log items!"

\end{code}

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

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

    realize :: Configuration -> IO (Switchboard a)
realize Configuration
cfg = Configuration -> IO (Switchboard a)
forall a.
(FromJSON a, ToJSON a) =>
Configuration -> IO (Switchboard a)
realizeSwitchboard Configuration
cfg
    unrealize :: Switchboard a -> IO ()
unrealize Switchboard a
switchboard = Switchboard a -> IO ()
forall a. Switchboard a -> IO ()
unrealizeSwitchboard Switchboard a
switchboard


realizeSwitchboard :: (FromJSON a, ToJSON a) => Configuration -> IO (Switchboard a)
realizeSwitchboard :: Configuration -> IO (Switchboard a)
realizeSwitchboard Configuration
cfg = do
    -- we setup |LogBuffer| explicitly so we can access it as a |Backend| and as |LogBuffer|
    LogBuffer a
logbuf :: Cardano.BM.Backend.LogBuffer.LogBuffer a <- Configuration -> IO (LogBuffer a)
forall (t :: * -> *) a. IsBackend t a => Configuration -> IO (t a)
Cardano.BM.Backend.LogBuffer.realize Configuration
cfg
    Log a
katipBE :: Cardano.BM.Backend.Log.Log a <- Configuration -> IO (Log a)
forall (t :: * -> *) a. IsBackend t a => Configuration -> IO (t a)
Cardano.BM.Backend.Log.realize Configuration
cfg
    let spawnDispatcher :: Switchboard a -> TBQ.TBQueue (LogObject a) -> IO (Async.Async ())
        spawnDispatcher :: Switchboard a -> TBQueue (LogObject a) -> IO (Async ())
spawnDispatcher Switchboard a
switchboard TBQueue (LogObject a)
queue =

            let sendMessage :: LogObject a -> ([BackendKind] -> t BackendKind) -> IO ()
sendMessage LogObject a
nli [BackendKind] -> t BackendKind
befilter = do
                    let name :: LoggerName
name = case LogObject a
nli of
                            LogObject loname _ (LogValue valueName _) ->
                                LoggerName
loname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
"." LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
valueName
                            LogObject loname _ _ -> LoggerName
loname
                    [BackendKind]
selectedBackends <- Configuration -> LoggerName -> IO [BackendKind]
getBackends Configuration
cfg LoggerName
name
                    let selBEs :: t BackendKind
selBEs = [BackendKind] -> t BackendKind
befilter [BackendKind]
selectedBackends
                    MVar (SwitchboardInternal a)
-> (SwitchboardInternal a -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard) ((SwitchboardInternal a -> IO ()) -> IO ())
-> (SwitchboardInternal a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SwitchboardInternal a
sb ->
                        [(BackendKind, Backend a)]
-> ((BackendKind, Backend a) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SwitchboardInternal a -> [(BackendKind, Backend a)]
forall a. SwitchboardInternal a -> NamedBackends a
sbBackends SwitchboardInternal a
sb) (((BackendKind, Backend a) -> IO ()) -> IO ())
-> ((BackendKind, Backend a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(BackendKind
bek, Backend a
be) ->
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BackendKind
bek BackendKind -> t BackendKind -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t BackendKind
selBEs) (Backend a -> LogObject a -> IO ()
forall a. Backend a -> LogObject a -> IO ()
bEffectuate Backend a
be LogObject a
nli)

                qProc :: IO ()
qProc = do
                    -- read complete queue at once and process items
                    [LogObject a]
nlis <- STM [LogObject a] -> IO [LogObject a]
forall a. STM a -> IO a
atomically (STM [LogObject a] -> IO [LogObject a])
-> STM [LogObject a] -> IO [LogObject a]
forall a b. (a -> b) -> a -> b
$ do
                                  [LogObject a]
r <- TBQueue (LogObject a) -> STM [LogObject a]
forall a. TBQueue a -> STM [a]
TBQ.flushTBQueue TBQueue (LogObject a)
queue
                                  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LogObject a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LogObject a]
r) STM ()
forall a. STM a
retry
                                  [LogObject a] -> STM [LogObject a]
forall (m :: * -> *) a. Monad m => a -> m a
return [LogObject a]
r

                    let processItem :: LogObject a -> IO Bool
processItem nli :: LogObject a
nli@(LogObject LoggerName
loname LOMeta
_ LOContent a
loitem) = do
                            Configuration -> LoggerName -> IO (Maybe SubTrace)
Config.findSubTrace Configuration
cfg LoggerName
loname IO (Maybe SubTrace) -> (Maybe SubTrace -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                Just (TeeTrace LoggerName
sndName) ->
                                    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (LogObject a) -> LogObject a -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQ.writeTBQueue TBQueue (LogObject a)
queue (LogObject a -> STM ()) -> LogObject a -> STM ()
forall a b. (a -> b) -> a -> b
$ LogObject a
nli{ loName :: LoggerName
loName = LoggerName
loname LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
"." LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
sndName }
                                Maybe SubTrace
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                            case LOContent a
loitem of
                                LOContent a
KillPill -> do
                                    -- each of the backends will be terminated sequentially
                                    MVar (SwitchboardInternal a)
-> (SwitchboardInternal a -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard) ((SwitchboardInternal a -> IO ()) -> IO ())
-> (SwitchboardInternal a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SwitchboardInternal a
sb ->
                                        [(BackendKind, Backend a)]
-> ((BackendKind, Backend a) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SwitchboardInternal a -> [(BackendKind, Backend a)]
forall a. SwitchboardInternal a -> NamedBackends a
sbBackends SwitchboardInternal a
sb) ( \(BackendKind
_, Backend a
be) -> Backend a -> IO ()
forall a. Backend a -> IO ()
bUnrealize Backend a
be )
                                    -- all backends have terminated
                                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                                (AggregatedMessage [(LoggerName, Aggregated)]
_) -> do
                                    LogObject a -> ([BackendKind] -> [BackendKind]) -> IO ()
forall (t :: * -> *).
Foldable t =>
LogObject a -> ([BackendKind] -> t BackendKind) -> IO ()
sendMessage LogObject a
nli ((BackendKind -> Bool) -> [BackendKind] -> [BackendKind]
forall a. (a -> Bool) -> [a] -> [a]
filter (BackendKind -> BackendKind -> Bool
forall a. Eq a => a -> a -> Bool
/= BackendKind
AggregationBK))
                                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                (MonitoringEffect (MonitorAlert LoggerName
_)) -> do
                                    LogObject a -> ([BackendKind] -> [BackendKind]) -> IO ()
forall (t :: * -> *).
Foldable t =>
LogObject a -> ([BackendKind] -> t BackendKind) -> IO ()
sendMessage LogObject a
nli ((BackendKind -> Bool) -> [BackendKind] -> [BackendKind]
forall a. (a -> Bool) -> [a] -> [a]
filter (BackendKind -> BackendKind -> Bool
forall a. Eq a => a -> a -> Bool
/= BackendKind
MonitoringBK))
                                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                (MonitoringEffect (MonitorAlterGlobalSeverity Severity
sev)) -> do
                                    Configuration -> Severity -> IO ()
setMinSeverity Configuration
cfg Severity
sev
                                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                (MonitoringEffect (MonitorAlterSeverity LoggerName
loggerName Severity
sev)) -> do
                                    Configuration -> LoggerName -> Maybe Severity -> IO ()
setSeverity Configuration
cfg LoggerName
loggerName (Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
sev)
                                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                (Command (DumpBufferedTo BackendKind
bk)) -> do
                                    [(LoggerName, LogObject a)]
msgs <- LogBuffer a -> IO [(LoggerName, LogObject a)]
forall a. LogBuffer a -> IO [(LoggerName, LogObject a)]
Cardano.BM.Backend.LogBuffer.readBuffer LogBuffer a
logbuf
                                    [(LoggerName, LogObject a)]
-> ((LoggerName, LogObject a) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(LoggerName, LogObject a)]
msgs (\(LoggerName
lonm, LogObject a
lobj) -> LogObject a -> ([BackendKind] -> [BackendKind]) -> IO ()
forall (t :: * -> *).
Foldable t =>
LogObject a -> ([BackendKind] -> t BackendKind) -> IO ()
sendMessage (LogObject a
lobj {loName :: LoggerName
loName = LoggerName
lonm}) ([BackendKind] -> [BackendKind] -> [BackendKind]
forall a b. a -> b -> a
const [BackendKind
bk]))
                                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                LOContent a
_ -> do
                                    LogObject a -> ([BackendKind] -> [BackendKind]) -> IO ()
forall (t :: * -> *).
Foldable t =>
LogObject a -> ([BackendKind] -> t BackendKind) -> IO ()
sendMessage LogObject a
nli [BackendKind] -> [BackendKind]
forall a. a -> a
id
                                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

                    [Bool]
res <- (LogObject a -> IO Bool) -> [LogObject a] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LogObject a -> IO Bool
processItem [LogObject a]
nlis
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
res) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
qProc
            in
            IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async IO ()
qProc

#ifdef PERFORMANCE_TEST_QUEUE
    let qSize = 1000000
#else
    let qSize :: Natural
qSize = Natural
2048
#endif
    TBQueue (LogObject a)
q <- STM (TBQueue (LogObject a)) -> IO (TBQueue (LogObject a))
forall a. STM a -> IO a
atomically (STM (TBQueue (LogObject a)) -> IO (TBQueue (LogObject a)))
-> STM (TBQueue (LogObject a)) -> IO (TBQueue (LogObject a))
forall a b. (a -> b) -> a -> b
$ Natural -> STM (TBQueue (LogObject a))
forall a. Natural -> STM (TBQueue a)
TBQ.newTBQueue Natural
qSize
    MVar (SwitchboardInternal a)
sbref <- IO (MVar (SwitchboardInternal a))
forall a. IO (MVar a)
newEmptyMVar

    let Switchboard a
sb :: Switchboard a = MVar (SwitchboardInternal a) -> Switchboard a
forall a. SwitchboardMVar a -> Switchboard a
Switchboard MVar (SwitchboardInternal a)
sbref

    [BackendKind]
backends <- Configuration -> IO [BackendKind]
getSetupBackends Configuration
cfg
    [(BackendKind, Backend a)]
bs0 <- [BackendKind]
-> Configuration -> Switchboard a -> IO [(BackendKind, Backend a)]
forall a.
(FromJSON a, ToJSON a) =>
[BackendKind]
-> Configuration -> Switchboard a -> IO [(BackendKind, Backend a)]
setupBackends [BackendKind]
backends Configuration
cfg Switchboard a
sb
    (BackendKind, Backend a)
bs1 <- (BackendKind, Backend a) -> IO (BackendKind, Backend a)
forall (m :: * -> *) a. Monad m => a -> m a
return (BackendKind
LogBufferBK, MkBackend :: forall a. (LogObject a -> IO ()) -> IO () -> Backend a
MkBackend
                        { bEffectuate :: LogObject a -> IO ()
bEffectuate = LogBuffer a -> LogObject a -> IO ()
forall (t :: * -> *) a.
IsEffectuator t a =>
t a -> LogObject a -> IO ()
Cardano.BM.Backend.LogBuffer.effectuate LogBuffer a
logbuf
                        , bUnrealize :: IO ()
bUnrealize = LogBuffer a -> IO ()
forall (t :: * -> *) a. IsBackend t a => t a -> IO ()
Cardano.BM.Backend.LogBuffer.unrealize LogBuffer a
logbuf
                        })
    (BackendKind, Backend a)
bs2 <- (BackendKind, Backend a) -> IO (BackendKind, Backend a)
forall (m :: * -> *) a. Monad m => a -> m a
return (BackendKind
KatipBK, MkBackend :: forall a. (LogObject a -> IO ()) -> IO () -> Backend a
MkBackend
                        { bEffectuate :: LogObject a -> IO ()
bEffectuate = Log a -> LogObject a -> IO ()
forall (t :: * -> *) a.
IsEffectuator t a =>
t a -> LogObject a -> IO ()
Cardano.BM.Backend.Log.effectuate Log a
katipBE
                        , bUnrealize :: IO ()
bUnrealize = Log a -> IO ()
forall (t :: * -> *) a. IsBackend t a => t a -> IO ()
Cardano.BM.Backend.Log.unrealize Log a
katipBE
                        })

    let bs :: [(BackendKind, Backend a)]
bs = (BackendKind, Backend a)
bs2 (BackendKind, Backend a)
-> [(BackendKind, Backend a)] -> [(BackendKind, Backend a)]
forall a. a -> [a] -> [a]
: (BackendKind, Backend a)
bs1 (BackendKind, Backend a)
-> [(BackendKind, Backend a)] -> [(BackendKind, Backend a)]
forall a. a -> [a] -> [a]
: [(BackendKind, Backend a)]
bs0
    Async ()
dispatcher <- Switchboard a -> TBQueue (LogObject a) -> IO (Async ())
spawnDispatcher Switchboard a
sb TBQueue (LogObject a)
q
    -- 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.
    (SomeException -> Bool) -> Async () -> IO ()
forall a. (SomeException -> Bool) -> Async a -> IO ()
Async.linkOnly (Bool -> Bool
not (Bool -> Bool) -> (SomeException -> Bool) -> SomeException -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Bool
isBlockedIndefinitelyOnSTM) Async ()
dispatcher

    -- Modify the internal state of the switchboard, the switchboard
    -- is now running.
    MVar (SwitchboardInternal a) -> SwitchboardInternal a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (SwitchboardInternal a)
sbref (SwitchboardInternal a -> IO ()) -> SwitchboardInternal a -> IO ()
forall a b. (a -> b) -> a -> b
$ SwitchboardInternal :: forall a.
TBQueue (LogObject a)
-> Async ()
-> LogBuffer a
-> Log a
-> NamedBackends a
-> SwitchboardStatus
-> SwitchboardInternal a
SwitchboardInternal 
        { sbQueue :: TBQueue (LogObject a)
sbQueue = TBQueue (LogObject a)
q
        , sbDispatch :: Async ()
sbDispatch = Async ()
dispatcher
        , sbLogBuffer :: LogBuffer a
sbLogBuffer = LogBuffer a
logbuf
        , sbLogBE :: Log a
sbLogBE = Log a
katipBE
        , sbBackends :: [(BackendKind, Backend a)]
sbBackends = [(BackendKind, Backend a)]
bs
        , sbRunning :: SwitchboardStatus
sbRunning = SwitchboardStatus
SwitchboardRunning
        }

    Switchboard a -> IO (Switchboard a)
forall (m :: * -> *) a. Monad m => a -> m a
return Switchboard a
sb



unrealizeSwitchboard :: Switchboard a -> IO ()
unrealizeSwitchboard :: Switchboard a -> IO ()
unrealizeSwitchboard Switchboard a
switchboard = do
    -- Here we are doing a modification to send the "kill pill"
    -- to the queue and we are waiting for the dispather to exit.
    -- At the end, either return the result or throw an exception.
    Async ()
dispatcher <- MVar (SwitchboardInternal a)
-> (SwitchboardInternal a -> IO (Async ())) -> IO (Async ())
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard) ((SwitchboardInternal a -> IO (Async ())) -> IO (Async ()))
-> (SwitchboardInternal a -> IO (Async ())) -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ \SwitchboardInternal a
sb -> do
        let dispatcher :: Async ()
dispatcher  = SwitchboardInternal a -> Async ()
forall a. SwitchboardInternal a -> Async ()
sbDispatch SwitchboardInternal a
sb
        let queue :: TBQueue (LogObject a)
queue       = SwitchboardInternal a -> TBQueue (LogObject a)
forall a. SwitchboardInternal a -> TBQueue (LogObject a)
sbQueue SwitchboardInternal a
sb

        -- Create terminating item, the "kill pill".
        LogObject a
lo <- LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject (LoggerName -> LOMeta -> LOContent a -> LogObject a)
-> IO LoggerName -> IO (LOMeta -> LOContent a -> LogObject a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoggerName -> IO LoggerName
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoggerName
"kill.switchboard"
                        IO (LOMeta -> LOContent a -> LogObject a)
-> IO LOMeta -> IO (LOContent a -> LogObject a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Warning PrivacyAnnotation
Confidential)
                        IO (LOContent a -> LogObject a)
-> IO (LOContent a) -> IO (LogObject a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LOContent a -> IO (LOContent a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LOContent a
forall a. LOContent a
KillPill
    
        -- 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 (LogObject a) -> LogObject a -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQ.writeTBQueue TBQueue (LogObject a)
queue LogObject a
lo

        -- Return the dispatcher.
        Async () -> IO (Async ())
forall (m :: * -> *) a. Monad m => a -> m a
return Async ()
dispatcher

    -- 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

    -- Either raise an exception or return the result.
    (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

    -- Modify the state in the end so we signal that the switchboard is shut down.
    SwitchboardInternal a
_ <- MVar (SwitchboardInternal a)
-> (SwitchboardInternal a -> IO (SwitchboardInternal a))
-> IO (SwitchboardInternal a)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard) (\SwitchboardInternal a
sb -> SwitchboardInternal a -> IO (SwitchboardInternal a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SwitchboardInternal a -> IO (SwitchboardInternal a))
-> SwitchboardInternal a -> IO (SwitchboardInternal a)
forall a b. (a -> b) -> a -> b
$ SwitchboardInternal a
sb { sbRunning :: SwitchboardStatus
sbRunning = SwitchboardStatus
SwitchboardStopped })

    () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()



isBlockedIndefinitelyOnSTM :: SomeException -> Bool
isBlockedIndefinitelyOnSTM :: SomeException -> Bool
isBlockedIndefinitelyOnSTM SomeException
e =
  Maybe BlockedIndefinitelyOnSTM -> Bool
forall a. Maybe a -> Bool
isJust (SomeException -> Maybe BlockedIndefinitelyOnSTM
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe BlockedIndefinitelyOnSTM)

\end{code}

\subsubsection{Integrate with external backend}\label{code:addUserDefinedBackend}\index{addUserDefinedBackend}
\begin{code}
addUserDefinedBackend :: Switchboard a -> Backend a -> Text -> IO ()
addUserDefinedBackend :: Switchboard a -> Backend a -> LoggerName -> IO ()
addUserDefinedBackend Switchboard a
switchboard Backend a
be LoggerName
name =
    MVar (SwitchboardInternal a)
-> (SwitchboardInternal a -> IO (SwitchboardInternal a)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard) ((SwitchboardInternal a -> IO (SwitchboardInternal a)) -> IO ())
-> (SwitchboardInternal a -> IO (SwitchboardInternal a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SwitchboardInternal a
sb ->
        SwitchboardInternal a -> IO (SwitchboardInternal a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SwitchboardInternal a -> IO (SwitchboardInternal a))
-> SwitchboardInternal a -> IO (SwitchboardInternal a)
forall a b. (a -> b) -> a -> b
$ SwitchboardInternal a
sb { sbBackends :: NamedBackends a
sbBackends = (LoggerName -> BackendKind
UserDefinedBK LoggerName
name, Backend a
be) (BackendKind, Backend a) -> NamedBackends a -> NamedBackends a
forall a. a -> [a] -> [a]
: SwitchboardInternal a -> NamedBackends a
forall a. SwitchboardInternal a -> NamedBackends a
sbBackends SwitchboardInternal a
sb }
\end{code}

\subsubsection{Integrate with external backend}\label{code:addExternalBackend}\index{addExternalBackend}
\begin{code}
addExternalBackend :: Switchboard a -> Backend a -> BackendKind -> IO ()
addExternalBackend :: Switchboard a -> Backend a -> BackendKind -> IO ()
addExternalBackend Switchboard a
switchboard Backend a
be BackendKind
bk =
    MVar (SwitchboardInternal a)
-> (SwitchboardInternal a -> IO (SwitchboardInternal a)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard) ((SwitchboardInternal a -> IO (SwitchboardInternal a)) -> IO ())
-> (SwitchboardInternal a -> IO (SwitchboardInternal a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SwitchboardInternal a
sb ->
        SwitchboardInternal a -> IO (SwitchboardInternal a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SwitchboardInternal a -> IO (SwitchboardInternal a))
-> SwitchboardInternal a -> IO (SwitchboardInternal a)
forall a b. (a -> b) -> a -> b
$ SwitchboardInternal a
sb { sbBackends :: NamedBackends a
sbBackends = (BackendKind
bk, Backend a
be) (BackendKind, Backend a) -> NamedBackends a -> NamedBackends a
forall a. a -> [a] -> [a]
: SwitchboardInternal a -> NamedBackends a
forall a. SwitchboardInternal a -> NamedBackends a
sbBackends SwitchboardInternal a
sb }

\end{code}

\subsubsection{Integrate with external \emph{katip} scribe}\label{code:addExternalScribe}\index{addExternalScribe}
\begin{code}
addExternalScribe :: Switchboard a -> K.Scribe -> Text -> IO ()
addExternalScribe :: Switchboard a -> Scribe -> LoggerName -> IO ()
addExternalScribe Switchboard a
switchboard Scribe
sc LoggerName
name =
    MVar (SwitchboardInternal a)
-> (SwitchboardInternal a -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard) ((SwitchboardInternal a -> IO ()) -> IO ())
-> (SwitchboardInternal a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SwitchboardInternal a
sb ->
        Log a -> Scribe -> LoggerName -> IO ()
forall a. Log a -> Scribe -> LoggerName -> IO ()
Cardano.BM.Backend.Log.registerScribe (SwitchboardInternal a -> Log a
forall a. SwitchboardInternal a -> Log a
sbLogBE SwitchboardInternal a
sb) Scribe
sc LoggerName
name

\end{code}

\subsubsection{Waiting for the switchboard to terminate}\label{code:waitForTermination}\index{waitForTermination}
\begin{code}
waitForTermination :: Switchboard a -> IO ()
waitForTermination :: Switchboard a -> IO ()
waitForTermination Switchboard a
switchboard =
    MVar (SwitchboardInternal a) -> IO (Maybe (SwitchboardInternal a))
forall a. MVar a -> IO (Maybe a)
tryReadMVar (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard) IO (Maybe (SwitchboardInternal a))
-> (Maybe (SwitchboardInternal a) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (SwitchboardInternal a)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just SwitchboardInternal a
sb -> Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
Async.waitCatch  (SwitchboardInternal a -> Async ()
forall a. SwitchboardInternal a -> Async ()
sbDispatch SwitchboardInternal a
sb) IO (Either SomeException ()) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

\end{code}

\subsubsection{Reading the buffered log messages}\label{code:readLogBuffer}\index{readLogBuffer}
\begin{code}
readLogBuffer :: Switchboard a -> IO [(LoggerName, LogObject a)]
readLogBuffer :: Switchboard a -> IO [(LoggerName, LogObject a)]
readLogBuffer Switchboard a
switchboard = do
    SwitchboardInternal a
sb <- MVar (SwitchboardInternal a) -> IO (SwitchboardInternal a)
forall a. MVar a -> IO a
readMVar (Switchboard a -> MVar (SwitchboardInternal a)
forall a. Switchboard a -> SwitchboardMVar a
getSB Switchboard a
switchboard)
    LogBuffer a -> IO [(LoggerName, LogObject a)]
forall a. LogBuffer a -> IO [(LoggerName, LogObject a)]
Cardano.BM.Backend.LogBuffer.readBuffer (SwitchboardInternal a -> LogBuffer a
forall a. SwitchboardInternal a -> LogBuffer a
sbLogBuffer SwitchboardInternal a
sb)

\end{code}

\subsubsection{Realizing the backends according to configuration}
\label{code:setupBackends}\index{Switchboard!setupBackends}
\begin{code}
setupBackends :: (FromJSON a, ToJSON a)
              => [BackendKind]
              -> Configuration
              -> Switchboard a
              -> IO [(BackendKind, Backend a)]
setupBackends :: [BackendKind]
-> Configuration -> Switchboard a -> IO [(BackendKind, Backend a)]
setupBackends [BackendKind]
bes Configuration
c Switchboard a
sb = [BackendKind]
-> [(BackendKind, Backend a)] -> IO [(BackendKind, Backend a)]
setupBackendsAcc [BackendKind]
bes []
  where
    setupBackendsAcc :: [BackendKind]
-> [(BackendKind, Backend a)] -> IO [(BackendKind, Backend a)]
setupBackendsAcc [] [(BackendKind, Backend a)]
acc = [(BackendKind, Backend a)] -> IO [(BackendKind, Backend a)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(BackendKind, Backend a)]
acc
    setupBackendsAcc (BackendKind
bk : [BackendKind]
r) [(BackendKind, Backend a)]
acc = do
        BackendKind
-> Configuration -> Switchboard a -> IO (Maybe (Backend a))
forall a.
(FromJSON a, ToJSON a) =>
BackendKind
-> Configuration -> Switchboard a -> IO (Maybe (Backend a))
setupBackend' BackendKind
bk Configuration
c Switchboard a
sb IO (Maybe (Backend a))
-> (Maybe (Backend a) -> IO [(BackendKind, Backend a)])
-> IO [(BackendKind, Backend a)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (Backend a)
Nothing -> [BackendKind]
-> [(BackendKind, Backend a)] -> IO [(BackendKind, Backend a)]
setupBackendsAcc [BackendKind]
r [(BackendKind, Backend a)]
acc
            Just Backend a
be -> [BackendKind]
-> [(BackendKind, Backend a)] -> IO [(BackendKind, Backend a)]
setupBackendsAcc [BackendKind]
r ((BackendKind
bk,Backend a
be) (BackendKind, Backend a)
-> [(BackendKind, Backend a)] -> [(BackendKind, Backend a)]
forall a. a -> [a] -> [a]
: [(BackendKind, Backend a)]
acc)

setupBackend' :: (FromJSON a , ToJSON a) => BackendKind -> Configuration -> Switchboard a -> IO (Maybe (Backend a))
setupBackend' :: BackendKind
-> Configuration -> Switchboard a -> IO (Maybe (Backend a))
setupBackend' BackendKind
SwitchboardBK Configuration
_ Switchboard a
_ = String -> IO (Maybe (Backend a))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot instantiate a further Switchboard"
setupBackend' (UserDefinedBK LoggerName
_) Configuration
_ Switchboard a
_ = String -> IO (Maybe (Backend a))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot instantiate an user-defined backend"
setupBackend' BackendKind
MonitoringBK Configuration
_ Switchboard a
_ = Maybe (Backend a) -> IO (Maybe (Backend a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Backend a)
forall a. Maybe a
Nothing
setupBackend' BackendKind
AggregationBK Configuration
_ Switchboard a
_ = Maybe (Backend a) -> IO (Maybe (Backend a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Backend a)
forall a. Maybe a
Nothing
setupBackend' BackendKind
EditorBK Configuration
_ Switchboard a
_ = Maybe (Backend a) -> IO (Maybe (Backend a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Backend a)
forall a. Maybe a
Nothing
setupBackend' BackendKind
GraylogBK Configuration
_ Switchboard a
_ = Maybe (Backend a) -> IO (Maybe (Backend a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Backend a)
forall a. Maybe a
Nothing
setupBackend' BackendKind
EKGViewBK Configuration
_ Switchboard a
_ = Maybe (Backend a) -> IO (Maybe (Backend a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Backend a)
forall a. Maybe a
Nothing
setupBackend' BackendKind
KatipBK Configuration
_ Switchboard a
_ = Maybe (Backend a) -> IO (Maybe (Backend a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Backend a)
forall a. Maybe a
Nothing
setupBackend' BackendKind
LogBufferBK Configuration
_ Switchboard a
_ = Maybe (Backend a) -> IO (Maybe (Backend a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Backend a)
forall a. Maybe a
Nothing
setupBackend' BackendKind
TraceAcceptorBK Configuration
_ Switchboard a
_ = Maybe (Backend a) -> IO (Maybe (Backend a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Backend a)
forall a. Maybe a
Nothing
setupBackend' BackendKind
TraceForwarderBK Configuration
_ Switchboard a
_ = Maybe (Backend a) -> IO (Maybe (Backend a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Backend a)
forall a. Maybe a
Nothing

\end{code}