\subsection{Cardano.BM.Backend.LogBuffer} \label{module:Cardano.BM.Backend.LogBuffer} %if style == newcode \begin{code} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} module Cardano.BM.Backend.LogBuffer ( LogBuffer , readBuffer , effectuate , realize , unrealize ) where import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar) import Data.Aeson (FromJSON) import qualified Data.HashMap.Strict as HM import qualified Data.Text.IO as TIO import System.IO (stderr) import Cardano.BM.Data.Backend (BackendKind (LogBufferBK), IsBackend (..), IsEffectuator (..)) import Cardano.BM.Data.LogItem (LOContent (..), LoggerName, LogObject (..)) \end{code} %endif \subsubsection{Structure of LogBuffer}\label{code:LogBuffer}\index{LogBuffer} \begin{code} newtype LogBuffer a = LogBuffer { LogBuffer a -> LogBufferMVar a getLogBuf :: LogBufferMVar a } type LogBufferMVar a = MVar (LogBufferInternal a) data LogBufferInternal a = LogBufferInternal { LogBufferInternal a -> LogBufferMap a logBuffer :: !(LogBufferMap a) } \end{code} \subsubsection{Relation from log context name to log item} We keep the latest |LogObject| from a log context in a |HashMap|. \begin{code} type LogBufferMap a = HM.HashMap LoggerName (LogObject a) \end{code} \subsubsection{Read out the latest |LogObject|s} Returns a list of the maps keys and values. And, resets the map. \begin{code} readBuffer :: LogBuffer a -> IO [(LoggerName, LogObject a)] readBuffer :: LogBuffer a -> IO [(LoggerName, LogObject a)] readBuffer LogBuffer a buffer = MVar (LogBufferInternal a) -> (LogBufferInternal a -> IO (LogBufferInternal a, [(LoggerName, LogObject a)])) -> IO [(LoggerName, LogObject a)] forall a b. MVar a -> (a -> IO (a, b)) -> IO b modifyMVar (LogBuffer a -> MVar (LogBufferInternal a) forall a. LogBuffer a -> LogBufferMVar a getLogBuf LogBuffer a buffer) ((LogBufferInternal a -> IO (LogBufferInternal a, [(LoggerName, LogObject a)])) -> IO [(LoggerName, LogObject a)]) -> (LogBufferInternal a -> IO (LogBufferInternal a, [(LoggerName, LogObject a)])) -> IO [(LoggerName, LogObject a)] forall a b. (a -> b) -> a -> b $ \LogBufferInternal a currentBuffer -> do let !l :: [(LoggerName, LogObject a)] l = HashMap LoggerName (LogObject a) -> [(LoggerName, LogObject a)] forall k v. HashMap k v -> [(k, v)] HM.toList (HashMap LoggerName (LogObject a) -> [(LoggerName, LogObject a)]) -> HashMap LoggerName (LogObject a) -> [(LoggerName, LogObject a)] forall a b. (a -> b) -> a -> b $ LogBufferInternal a -> HashMap LoggerName (LogObject a) forall a. LogBufferInternal a -> LogBufferMap a logBuffer LogBufferInternal a currentBuffer (LogBufferInternal a, [(LoggerName, LogObject a)]) -> IO (LogBufferInternal a, [(LoggerName, LogObject a)]) forall (m :: * -> *) a. Monad m => a -> m a return (HashMap LoggerName (LogObject a) -> LogBufferInternal a forall a. LogBufferMap a -> LogBufferInternal a LogBufferInternal HashMap LoggerName (LogObject a) forall k v. HashMap k v HM.empty, [(LoggerName, LogObject a)] l) \end{code} \subsubsection{LogBuffer is an effectuator}\index{LogBuffer!instance of IsEffectuator} Function |effectuate| is called to pass in a |LogObject| for log buffering. \begin{code} instance IsEffectuator LogBuffer a where effectuate :: LogBuffer a -> LogObject a -> IO () effectuate LogBuffer a buffer lo :: LogObject a lo@(LogObject LoggerName loname LOMeta _lometa (LogValue LoggerName lvname Measurable _lvalue)) = MVar (LogBufferInternal a) -> (LogBufferInternal a -> IO (LogBufferInternal a)) -> IO () forall a. MVar a -> (a -> IO a) -> IO () modifyMVar_ (LogBuffer a -> MVar (LogBufferInternal a) forall a. LogBuffer a -> LogBufferMVar a getLogBuf LogBuffer a buffer) ((LogBufferInternal a -> IO (LogBufferInternal a)) -> IO ()) -> (LogBufferInternal a -> IO (LogBufferInternal a)) -> IO () forall a b. (a -> b) -> a -> b $ \LogBufferInternal a currentBuffer -> LogBufferInternal a -> IO (LogBufferInternal a) forall (m :: * -> *) a. Monad m => a -> m a return (LogBufferInternal a -> IO (LogBufferInternal a)) -> LogBufferInternal a -> IO (LogBufferInternal a) forall a b. (a -> b) -> a -> b $! LogBufferMap a -> LogBufferInternal a forall a. LogBufferMap a -> LogBufferInternal a LogBufferInternal (LogBufferMap a -> LogBufferInternal a) -> LogBufferMap a -> LogBufferInternal a forall a b. (a -> b) -> a -> b $ LoggerName -> LogObject a -> LogBufferMap a -> LogBufferMap a forall k v. (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v HM.insert (LoggerName "#buffered." LoggerName -> LoggerName -> LoggerName forall a. Semigroup a => a -> a -> a <> LoggerName loname LoggerName -> LoggerName -> LoggerName forall a. Semigroup a => a -> a -> a <> LoggerName "." LoggerName -> LoggerName -> LoggerName forall a. Semigroup a => a -> a -> a <> LoggerName lvname) LogObject a lo (LogBufferMap a -> LogBufferMap a) -> LogBufferMap a -> LogBufferMap a forall a b. (a -> b) -> a -> b $ LogBufferInternal a -> LogBufferMap a forall a. LogBufferInternal a -> LogBufferMap a logBuffer LogBufferInternal a currentBuffer effectuate LogBuffer a buffer lo :: LogObject a lo@(LogObject LoggerName loname LOMeta _lometa LOContent a _logitem) = MVar (LogBufferInternal a) -> (LogBufferInternal a -> IO (LogBufferInternal a)) -> IO () forall a. MVar a -> (a -> IO a) -> IO () modifyMVar_ (LogBuffer a -> MVar (LogBufferInternal a) forall a. LogBuffer a -> LogBufferMVar a getLogBuf LogBuffer a buffer) ((LogBufferInternal a -> IO (LogBufferInternal a)) -> IO ()) -> (LogBufferInternal a -> IO (LogBufferInternal a)) -> IO () forall a b. (a -> b) -> a -> b $ \LogBufferInternal a currentBuffer -> LogBufferInternal a -> IO (LogBufferInternal a) forall (m :: * -> *) a. Monad m => a -> m a return (LogBufferInternal a -> IO (LogBufferInternal a)) -> LogBufferInternal a -> IO (LogBufferInternal a) forall a b. (a -> b) -> a -> b $! LogBufferMap a -> LogBufferInternal a forall a. LogBufferMap a -> LogBufferInternal a LogBufferInternal (LogBufferMap a -> LogBufferInternal a) -> LogBufferMap a -> LogBufferInternal a forall a b. (a -> b) -> a -> b $ LoggerName -> LogObject a -> LogBufferMap a -> LogBufferMap a forall k v. (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v HM.insert (LoggerName "#buffered." LoggerName -> LoggerName -> LoggerName forall a. Semigroup a => a -> a -> a <> LoggerName loname) LogObject a lo (LogBufferMap a -> LogBufferMap a) -> LogBufferMap a -> LogBufferMap a forall a b. (a -> b) -> a -> b $ LogBufferInternal a -> LogBufferMap a forall a. LogBufferInternal a -> LogBufferMap a logBuffer LogBufferInternal a currentBuffer handleOverflow :: LogBuffer a -> IO () handleOverflow LogBuffer a _ = Handle -> LoggerName -> IO () TIO.hPutStrLn Handle stderr LoggerName "Notice: overflow in LogBuffer, dropping log items!" \end{code} \subsubsection{|LogBuffer| implements |Backend| functions}\index{LogBuffer!instance of IsBackend} |LogBuffer| is an |IsBackend| \begin{code} instance FromJSON a => IsBackend LogBuffer a where bekind :: LogBuffer a -> BackendKind bekind LogBuffer a _ = BackendKind LogBufferBK realize :: Configuration -> IO (LogBuffer a) realize Configuration _ = let emptyBuffer :: LogBufferInternal a emptyBuffer = LogBufferMap a -> LogBufferInternal a forall a. LogBufferMap a -> LogBufferInternal a LogBufferInternal LogBufferMap a forall k v. HashMap k v HM.empty in LogBufferMVar a -> LogBuffer a forall a. LogBufferMVar a -> LogBuffer a LogBuffer (LogBufferMVar a -> LogBuffer a) -> IO (LogBufferMVar a) -> IO (LogBuffer a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> LogBufferInternal a -> IO (LogBufferMVar a) forall a. a -> IO (MVar a) newMVar LogBufferInternal a forall a. LogBufferInternal a emptyBuffer unrealize :: LogBuffer a -> IO () unrealize LogBuffer a _ = () -> IO () forall (m :: * -> *) a. Monad m => a -> m a return () \end{code}