\subsection{Cardano.BM.Backend.Aggregation}
\label{code:Cardano.BM.Backend.Aggregation}
%if style == newcode
\begin{code}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cardano.BM.Backend.Aggregation
(
Aggregation
, plugin
) where
import qualified Control.Concurrent.Async as Async
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,
readMVar, tryTakeMVar, withMVar)
import Control.Concurrent.STM (atomically)
import qualified Control.Concurrent.STM.TBQueue as TBQ
import Control.Exception.Safe (throwM)
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.HashMap.Strict as HM
import Data.Text (Text, pack)
import qualified Data.Text.IO as TIO
import System.IO (stderr)
import Cardano.BM.Backend.ProcessQueue (processQueue)
import Cardano.BM.Configuration.Model (Configuration, getAggregatedKind)
import Cardano.BM.Data.Aggregated (Aggregated (..), EWMA (..),
Measurable (..), ewma, singletonStats, updateAggregation)
import Cardano.BM.Data.AggregatedKind (AggregatedKind (..))
import Cardano.BM.Data.Backend
import Cardano.BM.Data.Counter (Counter (..), CounterState (..),
nameCounter)
import Cardano.BM.Data.LogItem
import Cardano.BM.Data.Severity (Severity (..))
import Cardano.BM.Data.Tracer (traceWith)
import Cardano.BM.Plugin
import qualified Cardano.BM.Trace as Trace
\end{code}
%endif
\subsubsection{Plugin definition}
\begin{code}
plugin :: (IsEffectuator s a, ToJSON a, FromJSON a)
=> Configuration -> Trace.Trace IO a -> s a -> IO (Plugin a)
plugin :: Configuration -> Trace IO a -> s a -> IO (Plugin a)
plugin Configuration
config Trace IO a
trace s a
sb = do
Aggregation a
be :: Cardano.BM.Backend.Aggregation.Aggregation a <- Configuration -> Trace IO a -> s a -> IO (Aggregation a)
forall (t :: * -> *) a (s :: * -> *).
(IsBackend t a, IsEffectuator s a) =>
Configuration -> Trace IO a -> s a -> IO (t a)
realizefrom Configuration
config Trace IO a
trace s a
sb
Plugin a -> IO (Plugin a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Plugin a -> IO (Plugin a)) -> Plugin a -> IO (Plugin a)
forall a b. (a -> b) -> a -> b
$ Backend a -> BackendKind -> Plugin a
forall a. Backend a -> BackendKind -> Plugin a
BackendPlugin
(MkBackend :: forall a. (LogObject a -> IO ()) -> IO () -> Backend a
MkBackend { bEffectuate :: LogObject a -> IO ()
bEffectuate = Aggregation a -> LogObject a -> IO ()
forall (t :: * -> *) a.
IsEffectuator t a =>
t a -> LogObject a -> IO ()
effectuate Aggregation a
be, bUnrealize :: IO ()
bUnrealize = Aggregation a -> IO ()
forall (t :: * -> *) a. IsBackend t a => t a -> IO ()
unrealize Aggregation a
be })
(Aggregation a -> BackendKind
forall (t :: * -> *) a. IsBackend t a => t a -> BackendKind
bekind Aggregation a
be)
\end{code}
\subsubsection{Internal representation}\label{code:Aggregation}\index{Aggregation}
\begin{code}
type AggregationMVar a = MVar (AggregationInternal a)
newtype Aggregation a = Aggregation
{ Aggregation a -> AggregationMVar a
getAg :: AggregationMVar a }
data AggregationInternal a = AggregationInternal
{ AggregationInternal a -> TBQueue (Maybe (LogObject a))
agQueue :: TBQ.TBQueue (Maybe (LogObject a))
, AggregationInternal a -> Async ()
agDispatch :: Async.Async ()
}
\end{code}
\subsubsection{Relation from context name to aggregated statistics}
We keep the aggregated values (|Aggregated|) for a named context in a |HashMap|.
\begin{code}
type AggregationMap = HM.HashMap Text Aggregated
\end{code}
\subsubsection{|Aggregation| implements |effectuate|}\index{Aggregation!instance of IsEffectuator}
|Aggregation| is an |IsEffectuator|
Enter the log item into the |Aggregation| queue.
\begin{code}
instance IsEffectuator Aggregation a where
effectuate :: Aggregation a -> LogObject a -> IO ()
effectuate Aggregation a
agg LogObject a
item = do
AggregationInternal a
ag <- MVar (AggregationInternal a) -> IO (AggregationInternal a)
forall a. MVar a -> IO a
readMVar (Aggregation a -> MVar (AggregationInternal a)
forall a. Aggregation a -> AggregationMVar a
getAg Aggregation a
agg)
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 (Maybe (LogObject a)) -> STM Bool
forall a. TBQueue a -> STM Bool
TBQ.isFullTBQueue (AggregationInternal a -> TBQueue (Maybe (LogObject a))
forall a. AggregationInternal a -> TBQueue (Maybe (LogObject a))
agQueue AggregationInternal a
ag)
if Bool
nocapacity
then Aggregation a -> IO ()
forall (t :: * -> *) a. IsEffectuator t a => t a -> IO ()
handleOverflow Aggregation a
agg
else STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (LogObject a)) -> Maybe (LogObject a) -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQ.writeTBQueue (AggregationInternal a -> TBQueue (Maybe (LogObject a))
forall a. AggregationInternal a -> TBQueue (Maybe (LogObject a))
agQueue AggregationInternal a
ag) (Maybe (LogObject a) -> STM ()) -> Maybe (LogObject a) -> STM ()
forall a b. (a -> b) -> a -> b
$! LogObject a -> Maybe (LogObject a)
forall a. a -> Maybe a
Just LogObject a
item
handleOverflow :: Aggregation a -> IO ()
handleOverflow Aggregation a
_ = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr Text
"Notice: Aggregation's queue full, dropping log items!"
\end{code}
\subsubsection{|Aggregation| implements |Backend| functions}\index{Aggregation!instance of IsBackend}
|Aggregation| is an |IsBackend|
\begin{code}
instance FromJSON a => IsBackend Aggregation a where
bekind :: Aggregation a -> BackendKind
bekind Aggregation a
_ = BackendKind
AggregationBK
realize :: Configuration -> IO (Aggregation a)
realize Configuration
_ = String -> IO (Aggregation a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Aggregation cannot be instantiated by 'realize'"
realizefrom :: Configuration -> Trace IO a -> s a -> IO (Aggregation a)
realizefrom Configuration
config Trace IO a
trace s a
_ = do
MVar (AggregationInternal a)
aggref <- IO (MVar (AggregationInternal a))
forall a. IO (MVar a)
newEmptyMVar
#ifdef PERFORMANCE_TEST_QUEUE
let qSize = 1000000
#else
let qSize :: Natural
qSize = Natural
2048
#endif
TBQueue (Maybe (LogObject a))
aggregationQueue <- STM (TBQueue (Maybe (LogObject a)))
-> IO (TBQueue (Maybe (LogObject a)))
forall a. STM a -> IO a
atomically (STM (TBQueue (Maybe (LogObject a)))
-> IO (TBQueue (Maybe (LogObject a))))
-> STM (TBQueue (Maybe (LogObject a)))
-> IO (TBQueue (Maybe (LogObject a)))
forall a b. (a -> b) -> a -> b
$ Natural -> STM (TBQueue (Maybe (LogObject a)))
forall a. Natural -> STM (TBQueue a)
TBQ.newTBQueue Natural
qSize
Async ()
dispatcher <- Configuration
-> AggregationMap
-> TBQueue (Maybe (LogObject a))
-> Trace IO a
-> IO (Async ())
forall a.
Configuration
-> AggregationMap
-> TBQueue (Maybe (LogObject a))
-> Trace IO a
-> IO (Async ())
spawnDispatcher Configuration
config AggregationMap
forall k v. HashMap k v
HM.empty TBQueue (Maybe (LogObject a))
aggregationQueue Trace IO a
trace
Async () -> IO ()
forall a. Async a -> IO ()
Async.link Async ()
dispatcher
MVar (AggregationInternal a) -> AggregationInternal a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (AggregationInternal a)
aggref (AggregationInternal a -> IO ()) -> AggregationInternal a -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (LogObject a)) -> Async () -> AggregationInternal a
forall a.
TBQueue (Maybe (LogObject a)) -> Async () -> AggregationInternal a
AggregationInternal TBQueue (Maybe (LogObject a))
aggregationQueue Async ()
dispatcher
Aggregation a -> IO (Aggregation a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Aggregation a -> IO (Aggregation a))
-> Aggregation a -> IO (Aggregation a)
forall a b. (a -> b) -> a -> b
$ MVar (AggregationInternal a) -> Aggregation a
forall a. AggregationMVar a -> Aggregation a
Aggregation MVar (AggregationInternal a)
aggref
unrealize :: Aggregation a -> IO ()
unrealize Aggregation a
aggregation = do
let clearMVar :: MVar a -> IO ()
clearMVar = IO (Maybe a) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe a) -> IO ())
-> (MVar a -> IO (Maybe a)) -> MVar a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> IO (Maybe a)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar
(Async ()
dispatcher, TBQueue (Maybe (LogObject a))
queue) <- MVar (AggregationInternal a)
-> (AggregationInternal a
-> IO (Async (), TBQueue (Maybe (LogObject a))))
-> IO (Async (), TBQueue (Maybe (LogObject a)))
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Aggregation a -> MVar (AggregationInternal a)
forall a. Aggregation a -> AggregationMVar a
getAg Aggregation a
aggregation) (\AggregationInternal a
ag ->
(Async (), TBQueue (Maybe (LogObject a)))
-> IO (Async (), TBQueue (Maybe (LogObject a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (AggregationInternal a -> Async ()
forall a. AggregationInternal a -> Async ()
agDispatch AggregationInternal a
ag, AggregationInternal a -> TBQueue (Maybe (LogObject a))
forall a. AggregationInternal a -> TBQueue (Maybe (LogObject a))
agQueue AggregationInternal a
ag))
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (LogObject a)) -> Maybe (LogObject a) -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQ.writeTBQueue TBQueue (Maybe (LogObject a))
queue Maybe (LogObject a)
forall a. Maybe a
Nothing
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
(MVar (AggregationInternal a) -> IO ()
forall a. MVar a -> IO ()
clearMVar (MVar (AggregationInternal a) -> IO ())
-> (Aggregation a -> MVar (AggregationInternal a))
-> Aggregation a
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Aggregation a -> MVar (AggregationInternal a)
forall a. Aggregation a -> AggregationMVar a
getAg) Aggregation a
aggregation
\end{code}
\subsubsection{Asynchronously reading log items from the queue and their processing}
\begin{code}
spawnDispatcher :: Configuration
-> AggregationMap
-> TBQ.TBQueue (Maybe (LogObject a))
-> Trace.Trace IO a
-> IO (Async.Async ())
spawnDispatcher :: Configuration
-> AggregationMap
-> TBQueue (Maybe (LogObject a))
-> Trace IO a
-> IO (Async ())
spawnDispatcher Configuration
conf AggregationMap
aggMap TBQueue (Maybe (LogObject a))
aggregationQueue Trace IO a
basetrace =
let trace :: Trace IO a
trace = Text -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
Trace.appendName Text
"#aggregation" Trace IO a
basetrace
in
IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Trace IO a -> AggregationMap -> IO ()
qProc Trace IO a
trace AggregationMap
aggMap
where
qProc :: Trace IO a -> AggregationMap -> IO ()
qProc Trace IO a
trace AggregationMap
aggregatedMap =
TBQueue (Maybe (LogObject a))
-> (LogObject a
-> (Trace IO a, AggregationMap) -> IO (Trace IO a, AggregationMap))
-> (Trace IO a, AggregationMap)
-> ((Trace IO a, AggregationMap) -> IO ())
-> IO ()
forall a b.
TBQueue (Maybe (LogObject a))
-> (LogObject a -> b -> IO b) -> b -> (b -> IO ()) -> IO ()
processQueue
TBQueue (Maybe (LogObject a))
aggregationQueue
LogObject a
-> (Trace IO a, AggregationMap) -> IO (Trace IO a, AggregationMap)
forall a.
LogObject a
-> (Trace IO a, AggregationMap) -> IO (Trace IO a, AggregationMap)
processAggregated
(Trace IO a
trace, AggregationMap
aggregatedMap)
(\(Trace IO a, AggregationMap)
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
processAggregated :: LogObject a
-> (Trace IO a, AggregationMap) -> IO (Trace IO a, AggregationMap)
processAggregated lo :: LogObject a
lo@(LogObject Text
loname LOMeta
lm LOContent a
_) (Trace IO a
trace, AggregationMap
aggregatedMap) = do
(AggregationMap
updatedMap, [(Text, Aggregated)]
aggregations) <- LogObject a
-> AggregationMap
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
forall a.
LogObject a
-> AggregationMap
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
update LogObject a
lo AggregationMap
aggregatedMap Trace IO a
trace
Trace IO a -> Text -> Severity -> [(Text, Aggregated)] -> IO ()
forall a.
Trace IO a -> Text -> Severity -> [(Text, Aggregated)] -> IO ()
sendAggregated Trace IO a
trace Text
loname (LOMeta -> Severity
severity LOMeta
lm) [(Text, Aggregated)]
aggregations
(Trace IO a, AggregationMap) -> IO (Trace IO a, AggregationMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace IO a
trace, AggregationMap
updatedMap)
createNupdate :: Text -> Measurable -> LOMeta -> AggregationMap -> IO (Either Text Aggregated)
createNupdate :: Text
-> Measurable
-> LOMeta
-> AggregationMap
-> IO (Either Text Aggregated)
createNupdate Text
name Measurable
value LOMeta
lme AggregationMap
agmap = do
case Text -> AggregationMap -> Maybe Aggregated
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
name AggregationMap
agmap of
Maybe Aggregated
Nothing -> do
AggregatedKind
aggregatedKind <- Configuration -> Text -> IO AggregatedKind
getAggregatedKind Configuration
conf Text
name
case AggregatedKind
aggregatedKind of
AggregatedKind
StatsAK -> Either Text Aggregated -> IO (Either Text Aggregated)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Aggregated -> IO (Either Text Aggregated))
-> Either Text Aggregated -> IO (Either Text Aggregated)
forall a b. (a -> b) -> a -> b
$ Aggregated -> Either Text Aggregated
forall a b. b -> Either a b
Right (Measurable -> Aggregated
singletonStats Measurable
value)
EwmaAK Double
aEWMA ->
Either Text Aggregated -> IO (Either Text Aggregated)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Aggregated -> IO (Either Text Aggregated))
-> Either Text Aggregated -> IO (Either Text Aggregated)
forall a b. (a -> b) -> a -> b
$ EWMA -> Aggregated
AggregatedEWMA (EWMA -> Aggregated) -> Either Text EWMA -> Either Text Aggregated
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EWMA -> Measurable -> Either Text EWMA
ewma (Double -> EWMA
EmptyEWMA Double
aEWMA) Measurable
value
Just Aggregated
a -> Either Text Aggregated -> IO (Either Text Aggregated)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Aggregated -> IO (Either Text Aggregated))
-> Either Text Aggregated -> IO (Either Text Aggregated)
forall a b. (a -> b) -> a -> b
$ Measurable -> Aggregated -> Word64 -> Either Text Aggregated
updateAggregation Measurable
value Aggregated
a (UTCTime -> Word64
utc2ns (UTCTime -> Word64) -> UTCTime -> Word64
forall a b. (a -> b) -> a -> b
$ LOMeta -> UTCTime
tstamp LOMeta
lme)
update :: LogObject a
-> AggregationMap
-> Trace.Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
update :: LogObject a
-> AggregationMap
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
update (LogObject Text
loname LOMeta
lme (LogValue Text
iname Measurable
value)) AggregationMap
agmap Trace IO a
trace = do
let fullname :: Text
fullname = Text
loname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
iname
Either Text Aggregated
eitherAggregated <- Text
-> Measurable
-> LOMeta
-> AggregationMap
-> IO (Either Text Aggregated)
createNupdate Text
fullname Measurable
value LOMeta
lme AggregationMap
agmap
case Either Text Aggregated
eitherAggregated of
Right Aggregated
aggregated -> do
Trace IO a -> Text -> Severity -> [(Text, Aggregated)] -> IO ()
forall a.
Trace IO a -> Text -> Severity -> [(Text, Aggregated)] -> IO ()
sendAggregated Trace IO a
trace Text
fullname (LOMeta -> Severity
severity LOMeta
lme) [(Text
iname, Aggregated
aggregated)]
let updatedMap :: AggregationMap
updatedMap = (Maybe Aggregated -> Maybe Aggregated)
-> Text -> AggregationMap -> AggregationMap
forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HM.alter (Maybe Aggregated -> Maybe Aggregated -> Maybe Aggregated
forall a b. a -> b -> a
const (Maybe Aggregated -> Maybe Aggregated -> Maybe Aggregated)
-> Maybe Aggregated -> Maybe Aggregated -> Maybe Aggregated
forall a b. (a -> b) -> a -> b
$ Aggregated -> Maybe Aggregated
forall a. a -> Maybe a
Just (Aggregated -> Maybe Aggregated) -> Aggregated -> Maybe Aggregated
forall a b. (a -> b) -> a -> b
$ Aggregated
aggregated) Text
fullname AggregationMap
agmap
(AggregationMap, [(Text, Aggregated)])
-> IO (AggregationMap, [(Text, Aggregated)])
forall (m :: * -> *) a. Monad m => a -> m a
return (AggregationMap
updatedMap, [])
Left Text
w -> do
let trace' :: Trace IO a
trace' = Text -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
Trace.appendName Text
"update" Trace IO a
trace
Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
Trace.traceNamedObject Trace IO a
trace' ((LOMeta, LOContent a) -> IO ())
-> IO (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(,) (LOMeta -> LOContent a -> (LOMeta, LOContent a))
-> IO LOMeta -> IO (LOContent a -> (LOMeta, LOContent a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LOMeta -> IO LOMeta
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Warning PrivacyAnnotation
Public)
IO (LOContent a -> (LOMeta, LOContent a))
-> IO (LOContent a) -> IO (LOMeta, LOContent 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 (Text -> LOContent a
forall a. Text -> LOContent a
LogError Text
w)
(AggregationMap, [(Text, Aggregated)])
-> IO (AggregationMap, [(Text, Aggregated)])
forall (m :: * -> *) a. Monad m => a -> m a
return (AggregationMap
agmap, [])
update (LogObject Text
loname LOMeta
lme (ObserveDiff CounterState
counterState)) AggregationMap
agmap Trace IO a
trace =
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
forall a.
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
updateCounters (CounterState -> [Counter]
csCounters CounterState
counterState) LOMeta
lme (Text
loname, Text
"diff") AggregationMap
agmap [] Trace IO a
trace
update (LogObject Text
loname LOMeta
lme (ObserveOpen CounterState
counterState)) AggregationMap
agmap Trace IO a
trace =
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
forall a.
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
updateCounters (CounterState -> [Counter]
csCounters CounterState
counterState) LOMeta
lme (Text
loname, Text
"open") AggregationMap
agmap [] Trace IO a
trace
update (LogObject Text
loname LOMeta
lme (ObserveClose CounterState
counterState)) AggregationMap
agmap Trace IO a
trace =
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
forall a.
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
updateCounters (CounterState -> [Counter]
csCounters CounterState
counterState) LOMeta
lme (Text
loname, Text
"close") AggregationMap
agmap [] Trace IO a
trace
update (LogObject Text
loname LOMeta
lme (LogMessage a
_)) AggregationMap
agmap Trace IO a
trace = do
let iname :: Text
iname = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Severity -> String
forall a. Show a => a -> String
show (LOMeta -> Severity
severity LOMeta
lme)
let fullname :: Text
fullname = Text
loname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
iname
Either Text Aggregated
eitherAggregated <- Text
-> Measurable
-> LOMeta
-> AggregationMap
-> IO (Either Text Aggregated)
createNupdate Text
fullname (Integer -> Measurable
PureI Integer
0) LOMeta
lme AggregationMap
agmap
case Either Text Aggregated
eitherAggregated of
Right Aggregated
aggregated -> do
Trace IO a -> Text -> Severity -> [(Text, Aggregated)] -> IO ()
forall a.
Trace IO a -> Text -> Severity -> [(Text, Aggregated)] -> IO ()
sendAggregated Trace IO a
trace Text
fullname (LOMeta -> Severity
severity LOMeta
lme) [(Text
iname, Aggregated
aggregated)]
let updatedMap :: AggregationMap
updatedMap = (Maybe Aggregated -> Maybe Aggregated)
-> Text -> AggregationMap -> AggregationMap
forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HM.alter (Maybe Aggregated -> Maybe Aggregated -> Maybe Aggregated
forall a b. a -> b -> a
const (Maybe Aggregated -> Maybe Aggregated -> Maybe Aggregated)
-> Maybe Aggregated -> Maybe Aggregated -> Maybe Aggregated
forall a b. (a -> b) -> a -> b
$ Aggregated -> Maybe Aggregated
forall a. a -> Maybe a
Just (Aggregated -> Maybe Aggregated) -> Aggregated -> Maybe Aggregated
forall a b. (a -> b) -> a -> b
$ Aggregated
aggregated) Text
fullname AggregationMap
agmap
(AggregationMap, [(Text, Aggregated)])
-> IO (AggregationMap, [(Text, Aggregated)])
forall (m :: * -> *) a. Monad m => a -> m a
return (AggregationMap
updatedMap, [])
Left Text
w -> do
let trace' :: Trace IO a
trace' = Text -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
Trace.appendName Text
"update" Trace IO a
trace
Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
Trace.traceNamedObject Trace IO a
trace' ((LOMeta, LOContent a) -> IO ())
-> IO (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(,) (LOMeta -> LOContent a -> (LOMeta, LOContent a))
-> IO LOMeta -> IO (LOContent a -> (LOMeta, LOContent a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LOMeta -> IO LOMeta
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Warning PrivacyAnnotation
Public)
IO (LOContent a -> (LOMeta, LOContent a))
-> IO (LOContent a) -> IO (LOMeta, LOContent 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 (Text -> LOContent a
forall a. Text -> LOContent a
LogError Text
w)
(AggregationMap, [(Text, Aggregated)])
-> IO (AggregationMap, [(Text, Aggregated)])
forall (m :: * -> *) a. Monad m => a -> m a
return (AggregationMap
agmap, [])
update LogObject a
_ AggregationMap
agmap Trace IO a
_ = (AggregationMap, [(Text, Aggregated)])
-> IO (AggregationMap, [(Text, Aggregated)])
forall (m :: * -> *) a. Monad m => a -> m a
return (AggregationMap
agmap, [])
updateCounters :: [Counter]
-> LOMeta
-> (LoggerName,LoggerName)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace.Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
updateCounters :: [Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
updateCounters [] LOMeta
_ (Text, Text)
_ AggregationMap
aggrMap [(Text, Aggregated)]
aggs Trace IO a
_ = (AggregationMap, [(Text, Aggregated)])
-> IO (AggregationMap, [(Text, Aggregated)])
forall (m :: * -> *) a. Monad m => a -> m a
return (AggregationMap
aggrMap, [(Text, Aggregated)]
aggs)
updateCounters (Counter
counter : [Counter]
cs) LOMeta
lme (Text
logname, Text
msgname) AggregationMap
aggrMap [(Text, Aggregated)]
aggs Trace IO a
trace = do
let name :: Text
name = Counter -> Text
cName Counter
counter
subname :: Text
subname = Text
msgname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Counter -> Text
nameCounter Counter
counter) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
fullname :: Text
fullname = Text
logname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
subname
value :: Measurable
value = Counter -> Measurable
cValue Counter
counter
Either Text Aggregated
eitherAggregated <- Text
-> Measurable
-> LOMeta
-> AggregationMap
-> IO (Either Text Aggregated)
createNupdate Text
fullname Measurable
value LOMeta
lme AggregationMap
aggrMap
case Either Text Aggregated
eitherAggregated of
Right Aggregated
aggregated -> do
let namedAggregated :: (Text, Aggregated)
namedAggregated = (Text
subname, Aggregated
aggregated)
updatedMap :: AggregationMap
updatedMap = (Maybe Aggregated -> Maybe Aggregated)
-> Text -> AggregationMap -> AggregationMap
forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HM.alter (Maybe Aggregated -> Maybe Aggregated -> Maybe Aggregated
forall a b. a -> b -> a
const (Maybe Aggregated -> Maybe Aggregated -> Maybe Aggregated)
-> Maybe Aggregated -> Maybe Aggregated -> Maybe Aggregated
forall a b. (a -> b) -> a -> b
$ Aggregated -> Maybe Aggregated
forall a. a -> Maybe a
Just (Aggregated -> Maybe Aggregated) -> Aggregated -> Maybe Aggregated
forall a b. (a -> b) -> a -> b
$ Aggregated
aggregated) Text
fullname AggregationMap
aggrMap
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
forall a.
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
updateCounters [Counter]
cs LOMeta
lme (Text
logname, Text
msgname) AggregationMap
updatedMap ((Text, Aggregated)
namedAggregated (Text, Aggregated) -> [(Text, Aggregated)] -> [(Text, Aggregated)]
forall a. a -> [a] -> [a]
: [(Text, Aggregated)]
aggs) Trace IO a
trace
Left Text
w -> do
let trace' :: Trace IO a
trace' = Text -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
Trace.appendName Text
"updateCounters" Trace IO a
trace
Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
Trace.traceNamedObject Trace IO a
trace' ((LOMeta, LOContent a) -> IO ())
-> IO (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(,) (LOMeta -> LOContent a -> (LOMeta, LOContent a))
-> IO LOMeta -> IO (LOContent a -> (LOMeta, LOContent a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LOMeta -> IO LOMeta
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Warning PrivacyAnnotation
Public)
IO (LOContent a -> (LOMeta, LOContent a))
-> IO (LOContent a) -> IO (LOMeta, LOContent 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 (Text -> LOContent a
forall a. Text -> LOContent a
LogError Text
w)
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
forall a.
[Counter]
-> LOMeta
-> (Text, Text)
-> AggregationMap
-> [(Text, Aggregated)]
-> Trace IO a
-> IO (AggregationMap, [(Text, Aggregated)])
updateCounters [Counter]
cs LOMeta
lme (Text
logname, Text
msgname) AggregationMap
aggrMap [(Text, Aggregated)]
aggs Trace IO a
trace
sendAggregated :: Trace.Trace IO a -> Text -> Severity -> [(Text, Aggregated)] -> IO ()
sendAggregated :: Trace IO a -> Text -> Severity -> [(Text, Aggregated)] -> IO ()
sendAggregated Trace IO a
_trace Text
_loname Severity
_sev [] = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
sendAggregated Trace IO a
trace Text
loname Severity
sev [(Text, Aggregated)]
v = do
LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
sev PrivacyAnnotation
Public
Trace IO a -> (Text, LogObject a) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Trace IO a
trace (Text
loname, Text -> LOMeta -> LOContent a -> LogObject a
forall a. Text -> LOMeta -> LOContent a -> LogObject a
LogObject Text
forall a. Monoid a => a
mempty LOMeta
meta ([(Text, Aggregated)] -> LOContent a
forall a. [(Text, Aggregated)] -> LOContent a
AggregatedMessage [(Text, Aggregated)]
v))
\end{code}