\subsection{Cardano.BM.Observer.Monadic}
\label{code:Cardano.BM.Observer.Monadic}

%if style == newcode
\begin{code}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-@ LIQUID "--prune-unsorted" @-}

module Cardano.BM.Observer.Monadic
    (
      bracketObserveIO
    , bracketObserveM
    , bracketObserveX
      -- * observing functions
    , observeOpen
    , observeClose
    ) where

import           Control.Exception.Safe (MonadCatch, SomeException, catch, throwM)
import           Control.Monad (forM_)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Data.Maybe (fromMaybe)
import           Data.Text
import qualified Data.Text.IO as TIO
import           System.IO (stderr)

import           Cardano.BM.Data.Counter (CounterState (..), diffCounters)
import           Cardano.BM.Data.LogItem (LOContent (..), LOMeta,
                     PrivacyAnnotation(Confidential), mkLOMeta)
import           Cardano.BM.Data.Severity (Severity)
import qualified Cardano.BM.Configuration as Config
import           Cardano.BM.Counters (readCounters)
import           Cardano.BM.Data.SubTrace (SubTrace (Neutral, NoTrace))
import           Cardano.BM.Trace (Trace, traceNamedObject)
\end{code}
%endif

\subsubsection{Monadic.bracketObserverIO}
Observes an |IO| action. The subtrace type is found in the configuration with
the passed-in name.
\newline
\par\noindent
Microbenchmarking steps:
\newline
\par
1. Create a |trace| which will have been configured
   to observe things besides logging.

\begin{spec}
        import qualified Cardano.BM.Configuration.Model as CM
        . . .
        c <- config
        trace <- setupTrace (Right c) "demo-playground"
            where
                config :: IO CM.Configuration
                config = do
                    c <- CM.empty
                    CM.setMinSeverity c Debug
                    CM.setSetupBackends c [KatipBK, AggregationBK]
                    CM.setDefaultBackends c [KatipBK, AggregationBK]
                    CM.setSetupScribes c [ ScribeDefinition {
                                              scName = "stdout"
                                            , scKind = StdoutSK
                                            , scRotation = Nothing
                                            }
                                    ]
                    CM.setDefaultScribes c ["StdoutSK::stdout"]

                    return c
\end{spec}

2. |c| is the |Configuration| of |trace|. In order to
   enable the collection and processing of measurements
   (min, max, mean, std-dev) |AggregationBK| is needed.

\begin{spec}
        CM.setDefaultBackends c [KatipBK, AggregationBK]
\end{spec}
in a configuration file (YAML) means

\begin{spec}
        defaultBackends:
          - KatipBK
          - AggregationBK
\end{spec}

3. Set the measurements that you want to take by changing
   the configuration of the |trace| using |setSubTrace|,
   in order to declare the namespace where we want to
   enable the particular measurements and the list with
   the kind of measurements.

\begin{spec}
        CM.setSubTrace
            config
            "submit-tx"
            (Just $ ObservableTraceSelf observablesSet)
          where
            observablesSet = [MonotonicClock, MemoryStats]
\end{spec}

4. Find an action to measure. e.g.:

\begin{spec}
        runProtocolWithPipe x hdl proto `catch` (\ProtocolStopped -> return ())
\end{spec}

    and use |bracketObserveIO|. e.g.:


\begin{spec}
        bracketObserveIO trace "submit-tx" $
            runProtocolWithPipe x hdl proto `catch` (\ProtocolStopped -> return ())
\end{spec}

\begin{code}
bracketObserveIO :: Config.Configuration -> Trace IO a -> Severity -> Text -> IO t -> IO t
bracketObserveIO :: Configuration -> Trace IO a -> Severity -> Text -> IO t -> IO t
bracketObserveIO Configuration
config Trace IO a
trace Severity
severity Text
name IO t
action = do
    SubTrace
subTrace <- SubTrace -> Maybe SubTrace -> SubTrace
forall a. a -> Maybe a -> a
fromMaybe SubTrace
Neutral (Maybe SubTrace -> SubTrace) -> IO (Maybe SubTrace) -> IO SubTrace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Configuration -> Text -> IO (Maybe SubTrace)
Config.findSubTrace Configuration
config Text
name
    SubTrace -> Severity -> Trace IO a -> IO t -> IO t
forall a t. SubTrace -> Severity -> Trace IO a -> IO t -> IO t
bracketObserveIO' SubTrace
subTrace Severity
severity Trace IO a
trace IO t
action
  where
    bracketObserveIO' :: SubTrace -> Severity -> Trace IO a -> IO t -> IO t
    bracketObserveIO' :: SubTrace -> Severity -> Trace IO a -> IO t -> IO t
bracketObserveIO' SubTrace
NoTrace Severity
_ Trace IO a
_ IO t
act = IO t
act
    bracketObserveIO' SubTrace
subtrace Severity
sev Trace IO a
logTrace IO t
act = do
        Either SomeException CounterState
mCountersid <- SubTrace
-> Severity -> Trace IO a -> IO (Either SomeException CounterState)
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
SubTrace
-> Severity -> Trace m a -> m (Either SomeException CounterState)
observeOpen SubTrace
subtrace Severity
sev Trace IO a
logTrace

        -- run action; if an exception is caught it will be logged and rethrown.
        t
t <- IO t
act IO t -> (SomeException -> IO t) -> IO t
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
e :: SomeException) -> (Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr (String -> Text
pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)) IO () -> IO t -> IO t
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO t
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e))

        case Either SomeException CounterState
mCountersid of
            Left SomeException
openException ->
                -- since observeOpen faced an exception there is no reason to call observeClose
                -- however the result of the action is returned
                Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr (Text
"ObserveOpen: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
openException))
            Right CounterState
countersid -> do
                    Either SomeException ()
res <- SubTrace
-> Severity
-> Trace IO a
-> CounterState
-> [(LOMeta, LOContent a)]
-> IO (Either SomeException ())
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m (Either SomeException ())
observeClose SubTrace
subtrace Severity
sev Trace IO a
logTrace CounterState
countersid []
                    case Either SomeException ()
res of
                        Left SomeException
ex -> Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr (Text
"ObserveClose: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
ex))
                        Either SomeException ()
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        t -> IO t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t

\end{code}

\subsubsection{Monadic.bracketObserverM}
Observes a |MonadIO m => m| action.
\begin{code}
bracketObserveM :: (MonadCatch m, MonadIO m) => Config.Configuration -> Trace m a -> Severity -> Text -> m t -> m t
bracketObserveM :: Configuration -> Trace m a -> Severity -> Text -> m t -> m t
bracketObserveM Configuration
config Trace m a
trace Severity
severity Text
name m t
action = do
    SubTrace
subTrace <- IO SubTrace -> m SubTrace
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SubTrace -> m SubTrace) -> IO SubTrace -> m SubTrace
forall a b. (a -> b) -> a -> b
$ SubTrace -> Maybe SubTrace -> SubTrace
forall a. a -> Maybe a -> a
fromMaybe SubTrace
Neutral (Maybe SubTrace -> SubTrace) -> IO (Maybe SubTrace) -> IO SubTrace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Configuration -> Text -> IO (Maybe SubTrace)
Config.findSubTrace Configuration
config Text
name
    SubTrace -> Severity -> Trace m a -> m t -> m t
forall (m :: * -> *) a t.
(MonadCatch m, MonadIO m) =>
SubTrace -> Severity -> Trace m a -> m t -> m t
bracketObserveM' SubTrace
subTrace Severity
severity Trace m a
trace m t
action
  where
    bracketObserveM' :: (MonadCatch m, MonadIO m) => SubTrace -> Severity -> Trace m a -> m t -> m t
    bracketObserveM' :: SubTrace -> Severity -> Trace m a -> m t -> m t
bracketObserveM' SubTrace
NoTrace Severity
_ Trace m a
_ m t
act = m t
act
    bracketObserveM' SubTrace
subtrace Severity
sev Trace m a
logTrace m t
act = do
        Either SomeException CounterState
mCountersid <- SubTrace
-> Severity -> Trace m a -> m (Either SomeException CounterState)
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
SubTrace
-> Severity -> Trace m a -> m (Either SomeException CounterState)
observeOpen SubTrace
subtrace Severity
sev Trace m a
logTrace

        -- run action; if an exception is caught it will be logged and rethrown.
        t
t <- m t
act m t -> (SomeException -> m t) -> m t
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
e :: SomeException) -> IO t -> m t
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr (String -> Text
pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)) IO () -> IO t -> IO t
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO t
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e))

        case Either SomeException CounterState
mCountersid of
            Left SomeException
openException ->
                -- since observeOpen faced an exception there is no reason to call observeClose
                -- however the result of the action is returned
                IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr (Text
"ObserveOpen: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
openException))
            Right CounterState
countersid -> do
                    Either SomeException ()
res <- SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m (Either SomeException ())
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m (Either SomeException ())
observeClose SubTrace
subtrace Severity
sev Trace m a
logTrace CounterState
countersid []
                    case Either SomeException ()
res of
                        Left SomeException
ex -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr (Text
"ObserveClose: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
ex)))
                        Either SomeException ()
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        t -> m t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t

\end{code}

\subsubsection{Monadic.bracketObserver}
Observes a |MonadIO m => m| action. This observer bracket does not interfere
on exceptions.
\begin{code}
bracketObserveX :: (MonadIO m) => Config.Configuration -> Trace m a -> Severity -> Text -> m t -> m t
bracketObserveX :: Configuration -> Trace m a -> Severity -> Text -> m t -> m t
bracketObserveX Configuration
config Trace m a
trace Severity
severity Text
name m t
action = do
    SubTrace
subTrace <- IO SubTrace -> m SubTrace
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SubTrace -> m SubTrace) -> IO SubTrace -> m SubTrace
forall a b. (a -> b) -> a -> b
$ SubTrace -> Maybe SubTrace -> SubTrace
forall a. a -> Maybe a -> a
fromMaybe SubTrace
Neutral (Maybe SubTrace -> SubTrace) -> IO (Maybe SubTrace) -> IO SubTrace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Configuration -> Text -> IO (Maybe SubTrace)
Config.findSubTrace Configuration
config Text
name
    SubTrace -> Severity -> Trace m a -> m t -> m t
forall (m :: * -> *) a t.
MonadIO m =>
SubTrace -> Severity -> Trace m a -> m t -> m t
bracketObserveX' SubTrace
subTrace Severity
severity Trace m a
trace m t
action
  where
    bracketObserveX' :: (MonadIO m) => SubTrace -> Severity -> Trace m a -> m t -> m t
    bracketObserveX' :: SubTrace -> Severity -> Trace m a -> m t -> m t
bracketObserveX' SubTrace
NoTrace Severity
_ Trace m a
_ m t
act = m t
act
    bracketObserveX' SubTrace
subtrace Severity
sev Trace m a
logTrace m t
act = do
        CounterState
countersid <- SubTrace -> Severity -> Trace m a -> m CounterState
forall (m :: * -> *) a.
MonadIO m =>
SubTrace -> Severity -> Trace m a -> m CounterState
observeOpen0 SubTrace
subtrace Severity
sev Trace m a
logTrace

        -- run action
        t
t <- m t
act

        SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m ()
forall (m :: * -> *) a.
MonadIO m =>
SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m ()
observeClose0 SubTrace
subtrace Severity
sev Trace m a
logTrace CounterState
countersid []

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

\end{code}

\subsubsection{observerOpen}\label{observeOpen}
\begin{code}
observeOpen :: (MonadCatch m, MonadIO m) => SubTrace -> Severity -> Trace m a -> m (Either SomeException CounterState)
observeOpen :: SubTrace
-> Severity -> Trace m a -> m (Either SomeException CounterState)
observeOpen SubTrace
subtrace Severity
severity Trace m a
logTrace = (do
    CounterState
state <- SubTrace -> Severity -> Trace m a -> m CounterState
forall (m :: * -> *) a.
MonadIO m =>
SubTrace -> Severity -> Trace m a -> m CounterState
observeOpen0 SubTrace
subtrace Severity
severity Trace m a
logTrace
    Either SomeException CounterState
-> m (Either SomeException CounterState)
forall (m :: * -> *) a. Monad m => a -> m a
return (CounterState -> Either SomeException CounterState
forall a b. b -> Either a b
Right CounterState
state)) m (Either SomeException CounterState)
-> (SomeException -> m (Either SomeException CounterState))
-> m (Either SomeException CounterState)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (Either SomeException CounterState
-> m (Either SomeException CounterState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException CounterState
 -> m (Either SomeException CounterState))
-> (SomeException -> Either SomeException CounterState)
-> SomeException
-> m (Either SomeException CounterState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException CounterState
forall a b. a -> Either a b
Left)

observeOpen0 :: (MonadIO m) => SubTrace -> Severity -> Trace m a -> m CounterState
observeOpen0 :: SubTrace -> Severity -> Trace m a -> m CounterState
observeOpen0 SubTrace
subtrace Severity
severity Trace m a
logTrace = do
    -- take measurement
    [Counter]
counters <- IO [Counter] -> m [Counter]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Counter] -> m [Counter]) -> IO [Counter] -> m [Counter]
forall a b. (a -> b) -> a -> b
$ SubTrace -> IO [Counter]
readCounters SubTrace
subtrace
    let state :: CounterState
state = [Counter] -> CounterState
CounterState [Counter]
counters
    if [Counter]
counters [Counter] -> [Counter] -> Bool
forall a. Eq a => a -> a -> Bool
== []
    then () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else do
        -- send opening message to Trace
        LOMeta
meta <- Severity -> PrivacyAnnotation -> m LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
severity PrivacyAnnotation
Confidential
        Trace m a -> (LOMeta, LOContent a) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace m a
logTrace (LOMeta
meta, CounterState -> LOContent a
forall a. CounterState -> LOContent a
ObserveOpen CounterState
state)
    CounterState -> m CounterState
forall (m :: * -> *) a. Monad m => a -> m a
return CounterState
state

\end{code}

\subsubsection{observeClose}\label{observeClose}
\begin{code}
observeClose
    :: (MonadCatch m, MonadIO m) => SubTrace -> Severity -> Trace m a
    -> CounterState -> [(LOMeta, LOContent a)]
    -> m (Either SomeException ())
observeClose :: SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m (Either SomeException ())
observeClose SubTrace
subtrace Severity
sev Trace m a
logTrace CounterState
initState [(LOMeta, LOContent a)]
logObjects = (do
    SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m ()
forall (m :: * -> *) a.
MonadIO m =>
SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m ()
observeClose0 SubTrace
subtrace Severity
sev Trace m a
logTrace CounterState
initState [(LOMeta, LOContent a)]
logObjects
    Either SomeException () -> m (Either SomeException ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either SomeException ()
forall a b. b -> Either a b
Right ())) m (Either SomeException ())
-> (SomeException -> m (Either SomeException ()))
-> m (Either SomeException ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (Either SomeException () -> m (Either SomeException ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException () -> m (Either SomeException ()))
-> (SomeException -> Either SomeException ())
-> SomeException
-> m (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException ()
forall a b. a -> Either a b
Left)

observeClose0 :: (MonadIO m) => SubTrace -> Severity -> Trace m a
    -> CounterState -> [(LOMeta, LOContent a)]
    -> m ()
observeClose0 :: SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m ()
observeClose0 SubTrace
subtrace Severity
sev Trace m a
logTrace CounterState
initState [(LOMeta, LOContent a)]
logObjects = do
    let initialCounters :: [Counter]
initialCounters = CounterState -> [Counter]
csCounters CounterState
initState

    -- take measurement
    [Counter]
counters <- IO [Counter] -> m [Counter]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Counter] -> m [Counter]) -> IO [Counter] -> m [Counter]
forall a b. (a -> b) -> a -> b
$ SubTrace -> IO [Counter]
readCounters SubTrace
subtrace
    if [Counter]
counters [Counter] -> [Counter] -> Bool
forall a. Eq a => a -> a -> Bool
== []
    then () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else do
        LOMeta
mle <- Severity -> PrivacyAnnotation -> m LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
sev PrivacyAnnotation
Confidential
        -- send closing message to Trace
        Trace m a -> (LOMeta, LOContent a) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace m a
logTrace ((LOMeta, LOContent a) -> m ()) -> (LOMeta, LOContent a) -> m ()
forall a b. (a -> b) -> a -> b
$
            (LOMeta
mle, CounterState -> LOContent a
forall a. CounterState -> LOContent a
ObserveClose ([Counter] -> CounterState
CounterState [Counter]
counters))
        -- send diff message to Trace
        Trace m a -> (LOMeta, LOContent a) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace m a
logTrace ((LOMeta, LOContent a) -> m ()) -> (LOMeta, LOContent a) -> m ()
forall a b. (a -> b) -> a -> b
$
            (LOMeta
mle, CounterState -> LOContent a
forall a. CounterState -> LOContent a
ObserveDiff ([Counter] -> CounterState
CounterState ([Counter] -> [Counter] -> [Counter]
diffCounters [Counter]
initialCounters [Counter]
counters)))
    -- trace the messages gathered from inside the action
    [(LOMeta, LOContent a)] -> ((LOMeta, LOContent a) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(LOMeta, LOContent a)]
logObjects (((LOMeta, LOContent a) -> m ()) -> m ())
-> ((LOMeta, LOContent a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Trace m a -> (LOMeta, LOContent a) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace m a
logTrace
    () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

\end{code}