\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
, addUserDefinedBackend
, addExternalBackend
, addExternalScribe
) 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
$
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
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
[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
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 )
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
(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
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
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
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
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
Async () -> IO (Async ())
forall (m :: * -> *) a. Monad m => a -> m a
return Async ()
dispatcher
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
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}