\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
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 ->
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
(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 ->
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}