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

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

module Cardano.BM.Observer.STM
    (
      bracketObserveIO
    , bracketObserveLogIO
    ) where

import           Control.Exception.Safe (SomeException, catch, throwM)
import qualified Control.Monad.STM as STM

import           Data.Maybe (fromMaybe)
import           Data.Text
import qualified Data.Text.IO as TIO
import           System.IO (stderr)

import qualified Cardano.BM.Configuration as Config
import           Cardano.BM.Data.LogItem (LOContent, LOMeta)
import           Cardano.BM.Data.SubTrace
import           Cardano.BM.Data.Severity (Severity)
import           Cardano.BM.Observer.Monadic (observeClose, observeOpen)
import           Cardano.BM.Trace (Trace)

\end{code}
%endif

\begin{code}
stmWithLog :: STM.STM (t, [(LOMeta, LOContent a)]) -> STM.STM (t, [(LOMeta, LOContent a)])
stmWithLog :: STM (t, [(LOMeta, LOContent a)])
-> STM (t, [(LOMeta, LOContent a)])
stmWithLog STM (t, [(LOMeta, LOContent a)])
action = STM (t, [(LOMeta, LOContent a)])
action

\end{code}

\subsubsection{Observe |STM| action in a named context}\label{code:bracketObserveIO}
With given name, create a |SubTrace| according to |Configuration|
and run the passed |STM| action on it.
\begin{code}
bracketObserveIO :: Config.Configuration -> Trace IO a -> Severity -> Text -> STM.STM t -> IO t
bracketObserveIO :: Configuration -> Trace IO a -> Severity -> Text -> STM t -> IO t
bracketObserveIO Configuration
config Trace IO a
trace Severity
severity Text
name STM 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 -> STM t -> IO t
forall a t. SubTrace -> Severity -> Trace IO a -> STM t -> IO t
bracketObserveIO' SubTrace
subTrace Severity
severity Trace IO a
trace STM t
action
  where
    bracketObserveIO' :: SubTrace -> Severity -> Trace IO a -> STM.STM t -> IO t
    bracketObserveIO' :: SubTrace -> Severity -> Trace IO a -> STM t -> IO t
bracketObserveIO' SubTrace
NoTrace Severity
_ Trace IO a
_ STM t
act =
        STM t -> IO t
forall a. STM a -> IO a
STM.atomically STM t
act
    bracketObserveIO' SubTrace
subtrace Severity
sev Trace IO a
logTrace STM 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, then it will be logged and rethrown.
        t
t <- (STM t -> IO t
forall a. STM a -> IO a
STM.atomically STM 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{Observe |STM| action in a named context and output captured log items}\label{code:bracketObserveLogIO}
The |STM| action might output messages, which after "success" will be forwarded to the logging trace.
Otherwise, this function behaves the same as |bracketObserveIO|.
\begin{code}
bracketObserveLogIO :: Config.Configuration -> Trace IO a -> Severity -> Text -> STM.STM (t,[(LOMeta, LOContent a)]) -> IO t
bracketObserveLogIO :: Configuration
-> Trace IO a
-> Severity
-> Text
-> STM (t, [(LOMeta, LOContent a)])
-> IO t
bracketObserveLogIO Configuration
config Trace IO a
trace Severity
severity Text
name STM (t, [(LOMeta, LOContent a)])
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
-> STM (t, [(LOMeta, LOContent a)])
-> IO t
forall a t.
SubTrace
-> Severity
-> Trace IO a
-> STM (t, [(LOMeta, LOContent a)])
-> IO t
bracketObserveLogIO' SubTrace
subTrace Severity
severity Trace IO a
trace STM (t, [(LOMeta, LOContent a)])
action
  where
    bracketObserveLogIO' :: SubTrace -> Severity -> Trace IO a -> STM.STM (t,[(LOMeta, LOContent a)]) -> IO t
    bracketObserveLogIO' :: SubTrace
-> Severity
-> Trace IO a
-> STM (t, [(LOMeta, LOContent a)])
-> IO t
bracketObserveLogIO' SubTrace
NoTrace Severity
_ Trace IO a
_ STM (t, [(LOMeta, LOContent a)])
act = do
        (t
t, [(LOMeta, LOContent a)]
_) <- STM (t, [(LOMeta, LOContent a)]) -> IO (t, [(LOMeta, LOContent a)])
forall a. STM a -> IO a
STM.atomically (STM (t, [(LOMeta, LOContent a)])
 -> IO (t, [(LOMeta, LOContent a)]))
-> STM (t, [(LOMeta, LOContent a)])
-> IO (t, [(LOMeta, LOContent a)])
forall a b. (a -> b) -> a -> b
$ STM (t, [(LOMeta, LOContent a)])
-> STM (t, [(LOMeta, LOContent a)])
forall t a.
STM (t, [(LOMeta, LOContent a)])
-> STM (t, [(LOMeta, LOContent a)])
stmWithLog STM (t, [(LOMeta, LOContent a)])
act
        t -> IO t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t
    bracketObserveLogIO' SubTrace
subtrace Severity
sev Trace IO a
logTrace STM (t, [(LOMeta, LOContent a)])
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, return result and log items; if an exception is
        -- caught, then it will be logged and rethrown.
        (t
t, [(LOMeta, LOContent a)]
as) <- (STM (t, [(LOMeta, LOContent a)]) -> IO (t, [(LOMeta, LOContent a)])
forall a. STM a -> IO a
STM.atomically (STM (t, [(LOMeta, LOContent a)])
 -> IO (t, [(LOMeta, LOContent a)]))
-> STM (t, [(LOMeta, LOContent a)])
-> IO (t, [(LOMeta, LOContent a)])
forall a b. (a -> b) -> a -> b
$ STM (t, [(LOMeta, LOContent a)])
-> STM (t, [(LOMeta, LOContent a)])
forall t a.
STM (t, [(LOMeta, LOContent a)])
-> STM (t, [(LOMeta, LOContent a)])
stmWithLog STM (t, [(LOMeta, LOContent a)])
act) IO (t, [(LOMeta, LOContent a)])
-> (SomeException -> IO (t, [(LOMeta, LOContent a)]))
-> IO (t, [(LOMeta, LOContent a)])
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, [(LOMeta, LOContent a)])
-> IO (t, [(LOMeta, LOContent a)])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO (t, [(LOMeta, LOContent a)])
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 [(LOMeta, LOContent a)]
as
                    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}