From f7b00e4bc1f4eda7658c4dc84333ccbee05fe973 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Wed, 18 Oct 2023 17:54:52 +0200 Subject: [PATCH 01/11] trace-dispatcher: core optimization and limiter 0 fixs plus inlining --- trace-dispatcher/doc/trace-dispatcher.md | 2 +- .../src/Cardano/Logging/Configuration.hs | 319 +++++++++--------- .../src/Cardano/Logging/FrequencyLimiter.hs | 2 +- trace-dispatcher/src/Cardano/Logging/Trace.hs | 113 ++++--- .../src/Cardano/Logging/Tracer/Composed.hs | 10 +- trace-dispatcher/src/Cardano/Logging/Types.hs | 2 +- trace-dispatcher/src/Control/Tracer.hs | 6 +- 7 files changed, 243 insertions(+), 211 deletions(-) diff --git a/trace-dispatcher/doc/trace-dispatcher.md b/trace-dispatcher/doc/trace-dispatcher.md index c4a07f3d0bc..e885b545f5c 100644 --- a/trace-dispatcher/doc/trace-dispatcher.md +++ b/trace-dispatcher/doc/trace-dispatcher.md @@ -407,7 +407,7 @@ foldTraceM :: MonadUnliftIO m -> Trace m (Folding a acc) -> m (Trace m a) -foldMTraceM :: MonadUnliftIO m +foldTraceM :: MonadUnliftIO m => (acc -> LoggingContext -> a -> m acc) -> acc -> Trace m (Folding a acc) diff --git a/trace-dispatcher/src/Cardano/Logging/Configuration.hs b/trace-dispatcher/src/Cardano/Logging/Configuration.hs index 1b637db29f3..f2a31dea397 100644 --- a/trace-dispatcher/src/Cardano/Logging/Configuration.hs +++ b/trace-dispatcher/src/Cardano/Logging/Configuration.hs @@ -78,38 +78,40 @@ maybeSilent :: forall m a. (MonadIO m) => -> m (Trace m a) maybeSilent selectorFunc prefixNames isMetrics (Trace tr) = do ref <- liftIO (newIORef Nothing) - pure $ Trace $ T.arrow $ T.emit $ mkTrace ref + contramapMCond (Trace tr) (mapFunc ref) where - mkTrace ref (lc, Right a) = do - silence <- liftIO $ readIORef ref - if silence == Just True - then pure () - else T.traceWith tr (lc, Right a) - mkTrace ref (lc, Left (TCConfig c)) = do - silence <- liftIO $ readIORef ref - case silence of - Nothing -> do - let val = selectorFunc c (Namespace prefixNames [] :: Namespace a) - liftIO $ writeIORef ref (Just val) - Just _ -> pure () - T.traceWith tr (lc, Left (TCConfig c)) - mkTrace ref (lc, Left TCReset) = do - liftIO $ writeIORef ref Nothing - T.traceWith tr (lc, Left TCReset) - mkTrace ref (lc, Left (TCOptimize cr)) = do - silence <- liftIO $ readIORef ref - case silence of - Just True -> liftIO $ if isMetrics - then modifyIORef (crNoMetrics cr) (Set.insert prefixNames) - else modifyIORef (crSilent cr) (Set.insert prefixNames) - _ -> pure () - liftIO $ modifyIORef (crAllTracers cr) (Set.insert prefixNames) - T.traceWith tr (lc, Left (TCOptimize cr)) - mkTrace ref (lc, Left c@TCDocument {}) = do - silence <- liftIO $ readIORef ref - unless isMetrics - (addSilent c silence) - T.traceWith tr (lc, Left c) + mapFunc ref = + \case + (lc, Right a) -> do + silence <- liftIO $ readIORef ref + if silence == Just True + then pure Nothing + else pure $ Just (lc, Right a) + (lc, Left (TCConfig c)) -> do + silence <- liftIO $ readIORef ref + case silence of + Nothing -> do + let val = selectorFunc c (Namespace prefixNames [] :: Namespace a) + liftIO $ writeIORef ref (Just val) + Just _ -> pure () + pure $ Just (lc, Left (TCConfig c)) + (lc, Left TCReset) -> do + liftIO $ writeIORef ref Nothing + pure $ Just (lc, Left TCReset) + (lc, Left (TCOptimize cr)) -> do + silence <- liftIO $ readIORef ref + case silence of + Just True -> liftIO $ if isMetrics + then modifyIORef (crNoMetrics cr) (Set.insert prefixNames) + else modifyIORef (crSilent cr) (Set.insert prefixNames) + _ -> pure () + liftIO $ modifyIORef (crAllTracers cr) (Set.insert prefixNames) + pure $ Just (lc, Left (TCOptimize cr)) + (lc, Left c@TCDocument {}) -> do + silence <- liftIO $ readIORef ref + unless isMetrics + (addSilent c silence) + pure $ Just (lc, Left c) -- When all messages are filtered out, it is silent @@ -148,109 +150,99 @@ withNamespaceConfig :: forall m a b c. (MonadIO m, Ord b) => -> m (Trace m a) withNamespaceConfig name extract withConfig tr = do ref <- liftIO (newIORef (Left (Map.empty, Nothing))) - pure $ Trace $ T.arrow $ T.emit $ mkTrace ref + contramapM' (mapFunc ref) where - mkTrace :: - IORef (Either (Map.Map [Text] b, Maybe b) b) - -> (LoggingContext, Either TraceControl a) - -> m () - mkTrace ref (lc, Right a) = do - eitherConf <- liftIO $ readIORef ref - case eitherConf of - Right val -> do - tt <- withConfig (Just val) tr - T.traceWith - (unpackTrace tt) (lc, Right a) - Left (cmap, Just v) -> - case Map.lookup (lcNSPrefix lc ++ lcNSInner lc) cmap of - Just val -> do - tt <- withConfig (Just val) tr - T.traceWith (unpackTrace tt) (lc, Right a) - Nothing -> do - tt <- withConfig (Just v) tr - T.traceWith (unpackTrace tt) (lc, Right a) - Left (_cmap, Nothing) -> pure () - -- This can happen during reconfiguration, so we don't throw an error any more - mkTrace ref (lc, Left TCReset) = do - liftIO $ writeIORef ref (Left (Map.empty, Nothing)) - tt <- withConfig Nothing tr - T.traceWith (unpackTrace tt) (lc, Left TCReset) - - mkTrace ref (lc, Left (TCConfig c)) = do - let nst = lcNSPrefix lc ++ lcNSInner lc - !val <- extract c (Namespace (lcNSPrefix lc) (lcNSInner lc)) - eitherConf <- liftIO $ readIORef ref - case eitherConf of - Left (cmap, Nothing) -> - case Map.lookup nst cmap of - Nothing -> do - liftIO - $ writeIORef ref (Left (Map.insert nst val cmap, Nothing)) - Trace tt <- withConfig (Just val) tr - -- trace ("config dict " ++ show (Map.insert nst val cmap)) $ - T.traceWith tt (lc, Left (TCConfig c)) - Just v -> do - if v == val - then do - Trace tt <- withConfig (Just val) tr - -- trace ("config val" ++ show val) $ - T.traceWith tt (lc, Left (TCConfig c)) - else error $ "Inconsistent trace configuration with context " - ++ show nst - Right _val -> error $ "Trace not reset before reconfiguration (1)" - ++ show nst - Left (_cmap, Just _v) -> error $ "Trace not reset before reconfiguration (2)" - ++ show nst - - mkTrace ref (lc, Left (TCOptimize cr)) = do - eitherConf <- liftIO $ readIORef ref - let nst = lcNSPrefix lc ++ lcNSInner lc - case eitherConf of - Left (cmap, Nothing) -> - case nub (Map.elems cmap) of - [] -> -- trace ("optimize no value " ++ show nst) $ - pure () - [val] -> do - liftIO $ writeIORef ref $ Right val - Trace tt <- withConfig (Just val) tr - -- trace ("optimize one value " ++ show nst ++ " val " ++ show val) $ - T.traceWith tt (lc, Left (TCOptimize cr)) - _ -> let decidingDict = - foldl - (\acc e -> Map.insertWith (+) e (1 :: Int) acc) - Map.empty - (Map.elems cmap) - (mostCommon, _) = maximumBy - (\(_, n') (_, m') -> compare n' m') - (Map.assocs decidingDict) - newmap = Map.filter (/= mostCommon) cmap - in do - liftIO $ writeIORef ref (Left (newmap, Just mostCommon)) - Trace tt <- withConfig Nothing tr - -- trace ("optimize dict " ++ show nst ++ " dict " ++ show newmap ++ " common " ++ show mostCommon) $ - T.traceWith tt (lc, Left (TCOptimize cr)) - Right _val -> error $ "Trace not reset before reconfiguration (3)" - ++ show nst - Left (_cmap, Just _v) -> - error $ "Trace not reset before reconfiguration (4)" - ++ show nst - mkTrace ref (lc, Left dc@TCDocument {}) = do - eitherConf <- liftIO $ readIORef ref - let nst = lcNSPrefix lc ++ lcNSInner lc - case eitherConf of - Right val -> do - tt <- withConfig (Just val) tr - T.traceWith - (unpackTrace tt) (lc, Left dc) - Left (cmap, Just v) -> - case Map.lookup nst cmap of - Just val -> do + mapFunc ref = + \case + (lc, Right a) -> do + eitherConf <- liftIO $ readIORef ref + case eitherConf of + Right val -> do + tt <- withConfig (Just val) tr + T.traceWith (unpackTrace tt) (lc, Right a) + Left (cmap, Just v) -> + case Map.lookup (lcNSPrefix lc ++ lcNSInner lc) cmap of + Just val -> do + tt <- withConfig (Just val) tr + T.traceWith (unpackTrace tt) (lc, Right a) + Nothing -> do + tt <- withConfig (Just v) tr + T.traceWith (unpackTrace tt) (lc, Right a) + -- This can happen during reconfiguration, so we don't throw an error any more + Left (_cmap, Nothing) -> pure () + (lc, Left TCReset) -> do + liftIO $ writeIORef ref (Left (Map.empty, Nothing)) + tt <- withConfig Nothing tr + T.traceWith (unpackTrace tt) (lc, Left TCReset) + (lc, Left (TCConfig c)) -> do + let nst = lcNSPrefix lc ++ lcNSInner lc + !val <- extract c (Namespace (lcNSPrefix lc) (lcNSInner lc)) + eitherConf <- liftIO $ readIORef ref + case eitherConf of + Left (cmap, Nothing) -> + case Map.lookup nst cmap of + Nothing -> do + liftIO + $ writeIORef ref (Left (Map.insert nst val cmap, Nothing)) tt <- withConfig (Just val) tr - T.traceWith (unpackTrace tt) (lc, Left dc) - Nothing -> do - tt <- withConfig (Just v) tr - T.traceWith (unpackTrace tt) (lc, Left dc) - Left (_cmap, Nothing) -> error ("Missing configuration(2) " <> name <> " ns " <> show nst) + T.traceWith (unpackTrace tt) (lc, Left (TCConfig c)) + Just v -> do + if v == val + then do + Trace tt <- withConfig (Just val) tr + T.traceWith tt (lc, Left (TCConfig c)) + else error $ "Inconsistent trace configuration with context " + ++ show nst + Right _val -> error $ "Trace not reset before reconfiguration (1)" + ++ show nst + Left (_cmap, Just _v) -> error $ "Trace not reset before reconfiguration (2)" + ++ show nst + (lc, Left (TCOptimize cr)) -> do + eitherConf <- liftIO $ readIORef ref + let nst = lcNSPrefix lc ++ lcNSInner lc + case eitherConf of + Left (cmap, Nothing) -> + case nub (Map.elems cmap) of + [] -> pure () + [val] -> do + liftIO $ writeIORef ref $ Right val + Trace tt <- withConfig (Just val) tr + T.traceWith tt (lc, Left (TCOptimize cr)) + _ -> let decidingDict = + foldl + (\acc e -> Map.insertWith (+) e (1 :: Int) acc) + Map.empty + (Map.elems cmap) + (mostCommon, _) = maximumBy + (\(_, n') (_, m') -> compare n' m') + (Map.assocs decidingDict) + newmap = Map.filter (/= mostCommon) cmap + in do + liftIO $ writeIORef ref (Left (newmap, Just mostCommon)) + Trace tt <- withConfig Nothing tr + T.traceWith tt (lc, Left (TCOptimize cr)) + Right _val -> error $ "Trace not reset before reconfiguration (3)" + ++ show nst + Left (_cmap, Just _v) -> + error $ "Trace not reset before reconfiguration (4)" + ++ show nst + (lc, Left dc@TCDocument {}) -> do + eitherConf <- liftIO $ readIORef ref + let nst = lcNSPrefix lc ++ lcNSInner lc + case eitherConf of + Right val -> do + tt <- withConfig (Just val) tr + T.traceWith + (unpackTrace tt) (lc, Left dc) + Left (cmap, Just v) -> + case Map.lookup nst cmap of + Just val -> do + tt <- withConfig (Just val) tr + T.traceWith (unpackTrace tt) (lc, Left dc) + Nothing -> do + tt <- withConfig (Just v) tr + T.traceWith (unpackTrace tt) (lc, Left dc) + Left (_cmap, Nothing) -> error ("Missing configuration(2) " <> name <> " ns " <> show nst) -- | Filter a trace by severity and take the filter value from the config @@ -261,18 +253,31 @@ filterSeverityFromConfig = withNamespaceConfig "severity" getSeverity' - (\ mbSev (Trace tr) -> - pure $ Trace $ T.arrow $ T.emit $ - \case - (lc, Left c@TCDocument {}) -> do - addFiltered c mbSev - T.traceWith - (unpackTrace (filterTraceBySeverity mbSev (Trace tr))) - (lc, Left c) - (lc, cont) -> do - T.traceWith - (unpackTrace (filterTraceBySeverity mbSev (Trace tr))) - (lc, cont)) + (\sev tr -> contramapMCond tr (mapF sev)) + where + mapF confSev = + \case + (lc, Left c@TCDocument {}) -> do + addFiltered c confSev + let visible = case lcSeverity lc of + (Just s) -> case confSev of + Just (SeverityF (Just fs)) -> s >= fs + Just (SeverityF Nothing) -> False + Nothing -> True + Nothing -> True + if visible + then pure $ Just (lc, Left c) + else pure Nothing + (lc, cont) -> do + let visible = case lcSeverity lc of + (Just s) -> case confSev of + Just (SeverityF (Just fs)) -> s >= fs + Just (SeverityF Nothing) -> False + Nothing -> True + Nothing -> True + if visible + then pure $ Just (lc, cont) + else pure Nothing -- | Set detail level of a trace from the config withDetailsFromConfig :: (MonadIO m) => @@ -331,15 +336,18 @@ withLimitersFromConfig tri tr = do getLimiter stateRef config ns = case getLimiterSpec config ns of Nothing -> pure Nothing - Just (name, frequency) -> do - state <- liftIO $ readIORef stateRef - case Map.lookup name state of - Just limiter -> pure $ Just limiter - Nothing -> do - limiterTrace <- limitFrequency frequency name tri tr - let limiter = Limiter name frequency limiterTrace - liftIO $ writeIORef stateRef (Map.insert name limiter state) - pure $ Just limiter + Just (name, frequency) -> + if frequency == 0 + then pure Nothing + else do + state <- liftIO $ readIORef stateRef + case Map.lookup name state of + Just limiter -> pure $ Just limiter + Nothing -> do + limiterTrace <- limitFrequency frequency name tri tr + let limiter = Limiter name frequency limiterTrace + liftIO $ writeIORef stateRef (Map.insert name limiter state) + pure $ Just limiter withLimiter :: Maybe (Maybe (Limiter m a)) @@ -348,8 +356,9 @@ withLimitersFromConfig tri tr = do withLimiter Nothing tr' = pure tr' withLimiter (Just Nothing) tr' = pure tr' withLimiter (Just (Just (Limiter n d (Trace trli)))) (Trace tr') = - pure $ Trace $ T.arrow $ T.emit $ - \ case + contramapM' (mapFunc (Limiter n d (Trace trli)) (Trace tr')) + mapFunc (Limiter n d (Trace trli)) (Trace tr') = + \case (lc, Right v) -> T.traceWith trli (lc, Right v) (lc, Left c@TCDocument {}) -> do diff --git a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs index 53aaf968447..6d505a9a9d6 100644 --- a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs +++ b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs @@ -80,7 +80,7 @@ limitFrequency -> m (Trace m a) -- the original trace limitFrequency thresholdFrequency limiterName ltracer vtracer = do timeNow <- systemTimeToSeconds <$> liftIO getSystemTime - foldMTraceM + foldTraceM (checkLimiting (1.0 / thresholdFrequency)) (FrequencyRec Nothing timeNow 0.0 0.0 Nothing) (Trace $ T.contramap unfoldTrace (unpackTrace (filterTraceMaybe vtracer))) diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs index f7c2f7139e0..af31dbf81dc 100644 --- a/trace-dispatcher/src/Cardano/Logging/Trace.hs +++ b/trace-dispatcher/src/Cardano/Logging/Trace.hs @@ -3,7 +3,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} - module Cardano.Logging.Trace ( traceWith , withLoggingContext @@ -23,9 +22,11 @@ module Cardano.Logging.Trace ( , setDetails , withDetails + , contramapM + , contramapMCond + , contramapM' , foldTraceM - , foldMTraceM - , foldMCondTraceM + , foldCondTraceM , routingTrace , appendPrefixName @@ -35,7 +36,7 @@ module Cardano.Logging.Trace ( , withInnerNames ) where -import Control.Monad (join, when) +import Control.Monad (join) import Control.Monad.IO.Unlift import qualified Control.Tracer as T import Data.Maybe (isJust) @@ -77,7 +78,7 @@ filterTraceMaybe (Trace tr) = Trace $ ( lc, Left ctrl) -> (lc, Left ctrl)) tr) ---- | Only processes messages further with a severity equal or greater as the +--- | Only processes messages further a severity equal or greater as the --- given one filterTraceBySeverity :: Monad m => Maybe SeverityF @@ -119,6 +120,7 @@ appendInnerName name (Trace tr) = Trace $ tr -- | Appends all names to the context. +{-# INLINE appendPrefixNames #-} appendPrefixNames :: Monad m => [Text] -> Trace m a -> Trace m a appendPrefixNames names (Trace tr) = Trace $ T.contramap @@ -135,6 +137,7 @@ appendInnerNames names (Trace tr) = Trace $ tr -- | Sets names for the messages in this trace based on the selector function +{-# INLINE withInnerNames #-} withInnerNames :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a withInnerNames (Trace tr) = Trace $ T.contramap @@ -217,6 +220,7 @@ withPrivacy (Trace tr) = Trace $ (lc, Left e) -> (lc, Left e)) tr where + {-# INLINE process #-} process lc cont@(Right v) = if isJust (lcPrivacy lc) then (lc,cont) @@ -248,6 +252,7 @@ withDetails (Trace tr) = Trace $ (lc, Left e) -> (lc, Left e)) tr where + {-# INLINE process #-} process lc cont@(Right v) = if isJust (lcDetails lc) then (lc,cont) @@ -259,76 +264,88 @@ withDetails (Trace tr) = Trace $ else (lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc) :: Namespace a) Nothing}, cont) --- | Folds the cata function with acc over a. --- Uses an MVar to store the state -foldTraceM - :: forall a acc m . (MonadUnliftIO m) - => (acc -> LoggingContext -> a -> acc) - -> acc - -> Trace m (Folding a acc) +-- | Contramap a monadic function over a trace +{-# INLINE contramapM #-} +contramapM :: Monad m + => Trace m b + -> ((LoggingContext, Either TraceControl a) + -> m (LoggingContext, Either TraceControl b)) -> m (Trace m a) -foldTraceM cata initial (Trace tr) = do - ref <- liftIO (newMVar initial) - let trr = mkTracer ref - pure $ Trace (T.Tracer trr) - where - mkTracer ref = T.emit $ - \case - (lc, Right v) -> do - x' <- modifyMVar ref $ \x -> - let !accu = cata x lc v - in pure (accu,accu) - T.traceWith tr (lc, Right (Folding x')) - (lc, Left control) -> do - T.traceWith tr (lc, Left control) - +contramapM (Trace tr) mFunc = + pure $ Trace $ T.Tracer $ T.emit rFunc + where + rFunc arg = do + res <- mFunc arg + T.traceWith tr res + +-- | Contramap a monadic function over a trace +-- Can as well filter out messages +{-# INLINE contramapMCond #-} +contramapMCond :: Monad m + => Trace m b + -> ((LoggingContext, Either TraceControl a) + -> m (Maybe (LoggingContext, Either TraceControl b))) + -> m (Trace m a) +contramapMCond (Trace tr) mFunc = + pure $ Trace $ T.Tracer $ T.emit rFunc + where + rFunc arg = do + condMes <- mFunc arg + case condMes of + Nothing -> pure () + Just mes -> T.traceWith tr mes + +{-# INLINE contramapM' #-} +contramapM' :: Monad m + => ((LoggingContext, Either TraceControl a) + -> m ()) + -> m (Trace m a) +contramapM' rFunc = + pure $ Trace $ T.Tracer $ T.emit rFunc -- | Folds the monadic cata function with acc over a. -- Uses an IORef to store the state -foldMTraceM +foldTraceM :: forall a acc m . (MonadUnliftIO m) => (acc -> LoggingContext -> a -> m acc) -> acc -> Trace m (Folding a acc) -> m (Trace m a) -foldMTraceM cata initial (Trace tr) = do +foldTraceM cata initial (Trace tr) = do ref <- liftIO (newMVar initial) - let trr = mkTracer ref - pure $ Trace (T.arrow trr) - where - mkTracer ref = T.emit $ - \case + contramapM (Trace tr) + (\case (lc, Right v) -> do x' <- modifyMVar ref $ \x -> do !accu <- cata x lc v pure $ join (,) accu - T.traceWith tr (lc, Right (Folding x')) + pure (lc, Right (Folding x')) (lc, Left control) -> do - T.traceWith tr (lc, Left control) + pure (lc, Left control)) --- | Like foldMTraceM, but filter the trace by a predicate. -foldMCondTraceM +-- | Like foldTraceM, but filter the trace by a predicate. +foldCondTraceM :: forall a acc m . (MonadUnliftIO m) => (acc -> LoggingContext -> a -> m acc) -> acc -> (a -> Bool) -> Trace m (Folding a acc) -> m (Trace m a) -foldMCondTraceM cata initial flt (Trace tr) = do +foldCondTraceM cata initial flt (Trace tr) = do ref <- liftIO (newMVar initial) - let trr = mkTracer ref - pure $ Trace (T.arrow trr) + contramapMCond (Trace tr) (foldF ref) where - mkTracer ref = T.emit $ + foldF ref = \case (lc, Right v) -> do x' <- modifyMVar ref $ \x -> do !accu <- cata x lc v pure $ join (,) accu - when (flt v) $ - T.traceWith tr (lc, Right (Folding x')) + if flt v + then pure $ Just (lc, Right (Folding x')) + else pure Nothing (lc, Left control) -> do - T.traceWith tr (lc, Left control) + pure $ Just (lc, Left control) -- | Allows to route to different tracers, based on the message being processed. -- The second argument must mappend all possible tracers of the first @@ -338,11 +355,11 @@ routingTrace => (a -> m (Trace m a)) -> Trace m a -> m (Trace m a) -routingTrace rf rc = pure $ Trace $ T.arrow $ T.emit $ - \case +routingTrace rf rc = contramapM' + (\case (lc, Right a) -> do nt <- rf a T.traceWith (unpackTrace nt) (lc, Right a) (lc, Left control) -> - T.traceWith (unpackTrace rc) (lc, Left control) + T.traceWith (unpackTrace rc) (lc, Left control)) diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs index d5aa1cc707c..cb027c850c4 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs @@ -89,22 +89,24 @@ mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do Just ekgTrace -> pure (metricsFormatter "" ekgTrace) -- >>= recordMetricsStatistics internalTr +-- >>= filterTrace (\(_,v) -> Prelude.null (asMetrics v)) >>= maybeSilent hasNoMetrics tracerPrefix True >>= hook pure (messageTrace <> metricsTrace) where + {-# INLINE addContextAndFilter #-} addContextAndFilter :: MetaTrace a => Trace IO a -> IO (Trace IO a) addContextAndFilter tr = do - tr' <- withDetailsFromConfig tr + tr' <- withDetailsFromConfig + $ withPrivacy + $ withDetails tr tr'' <- filterSeverityFromConfig tr' pure $ withInnerNames $ appendPrefixNames tracerPrefix $ withSeverity - $ withPrivacy - $ withDetails - tr'' + tr'' traceNamespaceErrors :: Trace IO TraceDispatcherMessage diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs index 1382ec0875d..79ca977a1f3 100644 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -490,7 +490,7 @@ data LogDoc = LogDoc { emptyLogDoc :: Text -> [(Text, Text)] -> LogDoc emptyLogDoc d m = LogDoc d (Map.fromList m) [] Nothing Nothing Nothing [] [] [] [] False --- | Type for the functions foldTraceM and foldMTraceM from module +-- | Type for the functions foldTraceM and foldTraceM from module -- Cardano/Logging/Trace newtype Folding a b = Folding b diff --git a/trace-dispatcher/src/Control/Tracer.hs b/trace-dispatcher/src/Control/Tracer.hs index 529c0aaf925..f391ce7403a 100644 --- a/trace-dispatcher/src/Control/Tracer.hs +++ b/trace-dispatcher/src/Control/Tracer.hs @@ -73,7 +73,7 @@ module Control.Tracer , Contravariant(..) ) where -import Control.Arrow ((|||), (&&&), arr, runKleisli) +import Control.Arrow (arr, runKleisli, (&&&), (|||)) import Control.Category ((>>>)) import Data.Functor.Contravariant (Contravariant (..)) import Debug.Trace (traceM) @@ -180,19 +180,23 @@ traceWith :: Monad m => Tracer m a -> a -> m () traceWith (Tracer tr) = runKleisli (Arrow.runTracerA tr) -- | Inverse of 'use'. +{-# INLINE arrow #-} arrow :: Arrow.TracerA m a () -> Tracer m a arrow = Tracer -- | Inverse of 'arrow'. Useful when writing arrow tracers which use a -- contravariant tracer (the newtype in this module). +{-# INLINE use #-} use :: Tracer m a -> Arrow.TracerA m a () use = runTracer -- | A tracer which does nothing. +{-# INLINE nullTracer #-} nullTracer :: Monad m => Tracer m a nullTracer = Tracer Arrow.squelch -- | Create a simple contravariant tracer which runs a given side-effect. +{-# INLINE emit #-} emit :: Applicative m => (a -> m ()) -> Tracer m a emit f = Tracer (Arrow.emit f) From dbcc206d002058df1cd60bcfcb0d2cc0cec99551 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Wed, 18 Oct 2023 16:28:11 +0200 Subject: [PATCH 02/11] cardano-node: renaming foldTraceM --- cardano-node/src/Cardano/Node/Tracing/Tracers.hs | 2 +- .../src/Cardano/Node/Tracing/Tracers/BlockReplayProgress.hs | 2 +- .../src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index e6e708cd3e7..29eb0f5b0b1 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -244,7 +244,7 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf -- Special blockFetch client metrics, send directly to EKG !blockFetchClientMetricsTr <- do - tr1 <- foldMTraceM calculateBlockFetchClientMetrics initialClientMetrics + tr1 <- foldTraceM calculateBlockFetchClientMetrics initialClientMetrics (metricsFormatter "" (mkMetricsTracer mbTrEKG)) pure $ filterTrace (\ (_, TraceLabelPeer _ m) -> case m of diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/BlockReplayProgress.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/BlockReplayProgress.hs index c978cc1bf92..cc354769d49 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/BlockReplayProgress.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/BlockReplayProgress.hs @@ -66,7 +66,7 @@ withReplayedBlock :: Trace IO ReplayBlockStats withReplayedBlock tr = let tr' = filterTrace filterFunction tr tr'' = contramap unfold tr' - in foldMTraceM replayBlockStats emptyReplayBlockStats tr'' + in foldTraceM replayBlockStats emptyReplayBlockStats tr'' where filterFunction(_, ReplayBlockStats {..}) = rpsDisplay diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs index 74d4a6cc7b8..a8f65badb58 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs @@ -159,7 +159,7 @@ forgeThreadStats :: Trace IO ForgingStats -> IO (Trace IO (ForgeTracerType blk)) forgeThreadStats tr = let tr' = contramap unfold tr - in foldMCondTraceM calculateThreadStats emptyForgingStats + in foldCondTraceM calculateThreadStats emptyForgingStats (\case Left Consensus.TraceStartLeadershipCheck{} -> True Left _ -> False From 57300e37412b161cf2e61b79f809a1995c62eaba Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Fri, 17 Nov 2023 15:02:02 +0100 Subject: [PATCH 03/11] trace-dispatcher: optimizations Use contramapM for preFormatted Formatting optim remove unused instances Strictness --- .../src/Cardano/Node/Tracing/Tracers.hs | 2 +- .../src/Cardano/Logging/Configuration.hs | 4 +- .../src/Cardano/Logging/Formatter.hs | 155 +++++++----------- trace-dispatcher/src/Cardano/Logging/Trace.hs | 22 ++- .../src/Cardano/Logging/Tracer/Composed.hs | 12 +- trace-dispatcher/src/Cardano/Logging/Types.hs | 52 +++--- trace-dispatcher/src/Control/Tracer/Arrow.hs | 4 + 7 files changed, 111 insertions(+), 140 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index 29eb0f5b0b1..7d7f37c0426 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -245,7 +245,7 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf -- Special blockFetch client metrics, send directly to EKG !blockFetchClientMetricsTr <- do tr1 <- foldTraceM calculateBlockFetchClientMetrics initialClientMetrics - (metricsFormatter "" + (metricsFormatter (mkMetricsTracer mbTrEKG)) pure $ filterTrace (\ (_, TraceLabelPeer _ m) -> case m of BlockFetch.CompletedBlockFetch {} -> True diff --git a/trace-dispatcher/src/Cardano/Logging/Configuration.hs b/trace-dispatcher/src/Cardano/Logging/Configuration.hs index f2a31dea397..692376647f2 100644 --- a/trace-dispatcher/src/Cardano/Logging/Configuration.hs +++ b/trace-dispatcher/src/Cardano/Logging/Configuration.hs @@ -150,7 +150,7 @@ withNamespaceConfig :: forall m a b c. (MonadIO m, Ord b) => -> m (Trace m a) withNamespaceConfig name extract withConfig tr = do ref <- liftIO (newIORef (Left (Map.empty, Nothing))) - contramapM' (mapFunc ref) + pure $ contramapM' (mapFunc ref) where mapFunc ref = \case @@ -356,7 +356,7 @@ withLimitersFromConfig tri tr = do withLimiter Nothing tr' = pure tr' withLimiter (Just Nothing) tr' = pure tr' withLimiter (Just (Just (Limiter n d (Trace trli)))) (Trace tr') = - contramapM' (mapFunc (Limiter n d (Trace trli)) (Trace tr')) + pure $ contramapM' (mapFunc (Limiter n d (Trace trli)) (Trace tr')) mapFunc (Limiter n d (Trace trli)) (Trace tr') = \case (lc, Right v) -> diff --git a/trace-dispatcher/src/Cardano/Logging/Formatter.hs b/trace-dispatcher/src/Cardano/Logging/Formatter.hs index 1a9ed53b9f8..474f9117087 100644 --- a/trace-dispatcher/src/Cardano/Logging/Formatter.hs +++ b/trace-dispatcher/src/Cardano/Logging/Formatter.hs @@ -19,40 +19,41 @@ import qualified Control.Tracer as T import Data.Aeson ((.=)) import qualified Data.Aeson as AE import qualified Data.Aeson.Encoding as AE -import qualified Data.ByteString.Lazy as BS import Data.Functor.Contravariant import Data.Maybe (fromMaybe) import Data.Text (Text, intercalate, pack, stripPrefix) -import Data.Text.Encoding (decodeUtf8) import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder as TB +import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) +import Cardano.Logging.Trace (contramapM) import Cardano.Logging.Types +import Cardano.Logging.Utils (showT) import Control.Concurrent (myThreadId) import Control.Monad.IO.Class (MonadIO, liftIO) import Network.HostName +encodingToText :: AE.Encoding -> Text +{-# INLINE encodingToText#-} +encodingToText = toStrict . decodeUtf8 . AE.encodingToLazyByteString + -- | Format this trace as metrics metricsFormatter :: forall a m . (LogFormatting a, MonadIO m) - => Text - -> Trace m FormattedMessage + => Trace m FormattedMessage -> Trace m a -metricsFormatter application (Trace tr) = Trace $ +metricsFormatter (Trace tr) = Trace $ T.contramap (\ case (lc, Right v) -> let metrics = asMetrics v - in (lc { lcNSPrefix = application : lcNSPrefix lc} - , Right (FormattedMetrics metrics)) + in (lc, Right (FormattedMetrics metrics)) (lc, Left ctrl) -> - (lc { lcNSPrefix = application : lcNSPrefix lc} - , Left ctrl)) + (lc, Left ctrl)) tr - -- | Transform this trace to a preformatted message, so that double serialization -- is avoided preFormatted :: @@ -63,15 +64,16 @@ preFormatted :: -> m (Trace m a) preFormatted backends' (Trace tr) = do hostname <- liftIO getHostName - pure $ Trace $ T.arrow $ T.emit $ - \ case + contramapM (Trace tr) + (\case (lc, Right msg) -> do time <- liftIO getCurrentTime threadId <- liftIO myThreadId - let threadText = fromMaybe - ((pack . show) threadId) - ((stripPrefix "ThreadId " . pack . show) threadId) - timestamp = time + let ns' = lcNSPrefix lc ++ lcNSInner lc + nsText = intercalate "." ns' + threadText = showT threadId + threadTextShortened = + fromMaybe threadText (stripPrefix "ThreadId " threadText) details = fromMaybe DNormal (lcDetails lc) condForHuman = if elem (Stdout HumanFormatUncoloured) backends' || elem (Stdout HumanFormatColoured) backends' @@ -81,18 +83,26 @@ preFormatted backends' (Trace tr) = do txt -> Just txt else Nothing machineFormatted = forMachine details msg - T.traceWith tr (lc, Right (PreFormatted - { pfMessage = msg - , pfForHuman = condForHuman - , pfForMachine = machineFormatted - , pfTimestamp = timeFormatted timestamp - , pfTime = timestamp - , pfNamespace = lcNSPrefix lc ++ lcNSInner lc - , pfHostname = hostname - , pfThreadId = threadText - })) + machineObj = AE.pairs $ + "at" .= time + <> "ns" .= nsText + <> "data" .= machineFormatted + <> "sev" .= fromMaybe Info (lcSeverity lc) + <> "thread" .= threadTextShortened + <> "host" .= hostname + + pure (lc, Right (PreFormatted + { pfMessage = msg + , pfForHuman = condForHuman + , pfForMachine = encodingToText machineObj + , pfTimestamp = timeFormatted time + , pfTime = time + , pfNamespace = ns' + , pfHostname = hostname + , pfThreadId = threadTextShortened + })) (lc, Left ctrl) -> - T.traceWith tr (lc, Left ctrl) + pure (lc, Left ctrl)) -- | Format this trace as TraceObject for the trace forwarder forwardFormatter' @@ -101,27 +111,14 @@ forwardFormatter' => Maybe Text -> Trace m FormattedMessage -> Trace m (PreFormatted a) -forwardFormatter' condApplication (Trace tr) = Trace $ +forwardFormatter' _condPrefix (Trace tr) = Trace $ contramap (\ case (lc, Right v) -> - let ns' = intercalate "." - (case condApplication of - Just app -> app : pfNamespace v - Nothing -> pfNamespace v) - machineObj = AE.pairs $ - "at" .= pfTimestamp v - <> "ns" .= ns' - <> "data" .= pfForMachine v - <> "sev" .= fromMaybe Info (lcSeverity lc) - <> "thread" .= pfThreadId v - <> "host" .= pfHostname v - forMachine' = decodeUtf8 - $ BS.toStrict - $ AE.encodingToLazyByteString machineObj + let to = TraceObject { toHuman = pfForHuman v - , toMachine = forMachine' + , toMachine = pfForMachine v , toNamespace = pfNamespace v , toSeverity = fromMaybe Info (lcSeverity lc) , toDetails = fromMaybe DNormal (lcDetails lc) @@ -130,11 +127,7 @@ forwardFormatter' condApplication (Trace tr) = Trace $ , toThreadId = pfThreadId v } in (lc, Right (FormattedForwarder to)) - (lc, Left ctrl) -> - (lc { lcNSPrefix = case condApplication of - Just app -> app : lcNSPrefix lc - Nothing -> lcNSPrefix lc} - , Left ctrl)) + (lc, Left ctrl) -> (lc, Left ctrl)) tr -- | Format this trace as TraceObject for the trace forwarder @@ -144,30 +137,11 @@ machineFormatter' => Maybe Text -> Trace m FormattedMessage -> Trace m (PreFormatted a) -machineFormatter' condApplication (Trace tr) = Trace $ +machineFormatter' _condPrefix (Trace tr) = Trace $ contramap (\ case - (lc, Right v) -> - let ns' = intercalate "." - (case condApplication of - Just app -> app : pfNamespace v - Nothing -> pfNamespace v) - machineObj = AE.pairs $ - "at" .= pfTimestamp v - <> "ns" .= ns' - <> "data" .= pfForMachine v - <> "sev" .= fromMaybe Info (lcSeverity lc) - <> "thread" .= pfThreadId v - <> "host" .= pfHostname v - forMachine' = decodeUtf8 - $ BS.toStrict - $ AE.encodingToLazyByteString machineObj - in (lc, Right (FormattedMachine forMachine')) - (lc, Left ctrl) -> - (lc { lcNSPrefix = case condApplication of - Just app -> app : lcNSPrefix lc - Nothing -> lcNSPrefix lc} - , Left ctrl)) + (lc, Right v) -> (lc, Right (FormattedMachine (pfForMachine v))) + (lc, Left ctrl) -> (lc, Left ctrl)) tr -- | Format this trace as TraceObject for the trace forwarder @@ -178,32 +152,27 @@ humanFormatter' -> Maybe Text -> Trace m FormattedMessage -> Trace m (PreFormatted a) -humanFormatter' withColor condApplication (Trace tr) = +humanFormatter' withColor _condPrefix (Trace tr) = Trace $ contramap (\ case (lc, Right v) -> - let ns' = intercalate "." - (case condApplication of - Just app -> app : pfNamespace v - Nothing -> pfNamespace v) + let ns' = fromText $ + intercalate "." (pfNamespace v) severity' = fromMaybe Info (lcSeverity lc) - ns = colorBySeverity + ns = colorBySeverity withColor severity' $ fromString (pfHostname v) <> singleton ':' - <> fromText ns' + <> ns' tadd = fromText " (" <> fromString (show severity') <> singleton ',' <> fromText (pfThreadId v) <> fromText ") " forHuman' = fromMaybe - (decodeUtf8 - $ BS.toStrict - $ AE.encodingToLazyByteString - $ AE.pairs ("data" .= pfForMachine v)) + (encodingToText (AE.pairs ("data" .= pfForMachine v))) (pfForHuman v) forHuman'' = toStrict $ toLazyText @@ -213,11 +182,7 @@ humanFormatter' withColor condApplication (Trace tr) = <> tadd <> fromText forHuman' in (lc, Right (FormattedHuman withColor forHuman'')) - (lc, Left ctrl) -> - (lc { lcNSPrefix = case condApplication of - Just app -> app : lcNSPrefix lc - Nothing -> lcNSPrefix lc} - , Left ctrl)) + (lc, Left ctrl) -> (lc, Left ctrl)) tr squareBrackets :: Builder -> Builder @@ -253,19 +218,19 @@ humanFormatter -> Maybe Text -> Trace m FormattedMessage -> m (Trace m a) -humanFormatter withColor condApplication tr = do - let tr' = humanFormatter' withColor condApplication tr - preFormatted [Stdout HumanFormatColoured] tr' +humanFormatter withColor condPrefix tr = do + let tr' = humanFormatter' withColor condPrefix tr + preFormatted [Stdout (if withColor then HumanFormatColoured else HumanFormatUncoloured)] tr' machineFormatter :: forall a m . - MonadIO m - => LogFormatting a + (MonadIO m + , LogFormatting a) => Maybe Text -> Trace m FormattedMessage -> m (Trace m a) -machineFormatter condApplication tr = do - let tr' = machineFormatter' condApplication tr +machineFormatter condPrefix tr = do + let tr' = machineFormatter' condPrefix tr preFormatted [Stdout MachineFormat] tr' forwardFormatter @@ -275,6 +240,6 @@ forwardFormatter => Maybe Text -> Trace m FormattedMessage -> m (Trace m a) -forwardFormatter condApplication tr = do - let tr' = forwardFormatter' condApplication tr +forwardFormatter condPrefix tr = do + let tr' = forwardFormatter' condPrefix tr preFormatted [Stdout MachineFormat, Stdout HumanFormatColoured] tr' diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs index af31dbf81dc..0fb10e9a25c 100644 --- a/trace-dispatcher/src/Cardano/Logging/Trace.hs +++ b/trace-dispatcher/src/Cardano/Logging/Trace.hs @@ -29,6 +29,7 @@ module Cardano.Logging.Trace ( , foldCondTraceM , routingTrace + , withNames , appendPrefixName , appendPrefixNames , appendInnerName @@ -146,6 +147,19 @@ withInnerNames (Trace tr) = Trace $ (lc, Left c) -> (lc, Left c)) tr +-- | Sets names for the messages in this trace based on the selector function +-- and appends the provided names to the context. +{-# INLINE withNames #-} +withNames :: forall m a. (Monad m, MetaTrace a) => [Text] -> Trace m a -> Trace m a +withNames names (Trace tr) = Trace $ + T.contramap + (\case + (lc, Right a) -> (lc {lcNSPrefix = names, + lcNSInner = nsInner (namespaceFor a)}, Right a) + (lc, Left c) -> (lc {lcNSPrefix = names}, Left c)) + tr + + -- | Sets severity for the messages in this trace setSeverity :: Monad m => SeverityS -> Trace m a -> Trace m a setSeverity s (Trace tr) = Trace $ @@ -156,6 +170,7 @@ setSeverity s (Trace tr) = Trace $ tr -- | Sets severities for the messages in this trace based on the MetaTrace class +{-# INLINE withSeverity #-} withSeverity :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a withSeverity (Trace tr) = Trace $ T.contramap @@ -166,6 +181,7 @@ withSeverity (Trace tr) = Trace $ (lc, Left e) -> (lc, Left e)) tr where + {-# INLINE process #-} process lc cont@(Right v) = if isJust (lcSeverity lc) then (lc,cont) @@ -299,9 +315,9 @@ contramapMCond (Trace tr) mFunc = contramapM' :: Monad m => ((LoggingContext, Either TraceControl a) -> m ()) - -> m (Trace m a) + -> Trace m a contramapM' rFunc = - pure $ Trace $ T.Tracer $ T.emit rFunc + Trace $ T.Tracer $ T.emit rFunc -- | Folds the monadic cata function with acc over a. -- Uses an IORef to store the state @@ -354,7 +370,7 @@ routingTrace :: forall m a. Monad m => (a -> m (Trace m a)) -> Trace m a - -> m (Trace m a) + -> Trace m a routingTrace rf rc = contramapM' (\case (lc, Right a) -> do diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs index cb027c850c4..713870d3ca6 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs @@ -59,7 +59,8 @@ mkCardanoTracer trStdout trForward mbTrEkg tracerPrefix = -- | Adds the possibility to add special tracers via the hook function mkCardanoTracer' :: forall evt evt1. ( LogFormatting evt1 - , MetaTrace evt1) + , MetaTrace evt1 + ) => Trace IO FormattedMessage -> Trace IO FormattedMessage -> Maybe (Trace IO FormattedMessage) @@ -87,9 +88,8 @@ mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do !metricsTrace <- case mbTrEkg of Nothing -> pure $ Trace T.nullTracer Just ekgTrace -> - pure (metricsFormatter "" ekgTrace) + pure (metricsFormatter ekgTrace) -- >>= recordMetricsStatistics internalTr --- >>= filterTrace (\(_,v) -> Prelude.null (asMetrics v)) >>= maybeSilent hasNoMetrics tracerPrefix True >>= hook @@ -103,10 +103,8 @@ mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do $ withPrivacy $ withDetails tr tr'' <- filterSeverityFromConfig tr' - pure $ withInnerNames - $ appendPrefixNames tracerPrefix - $ withSeverity - tr'' + pure $ withNames tracerPrefix + $ withSeverity tr'' traceNamespaceErrors :: Trace IO TraceDispatcherMessage diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs index 79ca977a1f3..b3e9d085110 100644 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -53,7 +53,7 @@ module Cardano.Logging.Types ( import Codec.Serialise (Serialise (..)) -import Data.Aeson ((.=)) +-- import Data.Aeson ((.=)) import qualified Data.Aeson as AE import qualified Data.HashMap.Strict as HM import Data.IORef @@ -68,6 +68,8 @@ import Network.HostName (HostName) import qualified Control.Tracer as T +-- + import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) @@ -118,6 +120,7 @@ nsReplaceInner i (Namespace o _) = Namespace o i nsPrependInner :: Text -> Namespace a -> Namespace b nsPrependInner t (Namespace o i) = Namespace o (t : i) +{-# INLINE nsCast #-} nsCast :: Namespace a -> Namespace b nsCast (Namespace o i) = Namespace o i @@ -310,26 +313,26 @@ data FormattedMessage = data PreFormatted a = PreFormatted { - pfMessage :: a - , pfForHuman :: Maybe Text - , pfForMachine :: AE.Object - , pfNamespace :: [Text] - , pfTimestamp :: Text - , pfTime :: UTCTime - , pfHostname :: HostName - , pfThreadId :: Text + pfMessage :: ! a + , pfForHuman :: ! (Maybe Text) + , pfForMachine :: ! Text + , pfNamespace :: ! [Text] + , pfTimestamp :: ! Text + , pfTime :: ! UTCTime + , pfHostname :: ! HostName + , pfThreadId :: ! Text } -- | Used as interface object for ForwarderTracer data TraceObject = TraceObject { - toHuman :: Maybe Text - , toMachine :: Text - , toNamespace :: [Text] - , toSeverity :: SeverityS - , toDetails :: DetailLevel - , toTimestamp :: UTCTime - , toHostname :: HostName - , toThreadId :: Text + toHuman :: ! (Maybe Text) + , toMachine :: ! Text + , toNamespace :: ! [Text] + , toSeverity :: ! SeverityS + , toDetails :: ! DetailLevel + , toTimestamp :: ! UTCTime + , toHostname :: ! HostName + , toThreadId :: ! Text } deriving (Eq, Show) -- | @@ -506,21 +509,6 @@ instance LogFormatting b => LogFormatting (Folding a b) where forHuman (Folding b) = forHuman b asMetrics (Folding b) = asMetrics b -instance LogFormatting Double where - forMachine _dtal d = "val" .= AE.String ((pack . show) d) - forHuman = pack . show - asMetrics d = [DoubleM "" d] - -instance LogFormatting Int where - forMachine _dtal i = "val" .= AE.String ((pack . show) i) - forHuman = pack . show - asMetrics i = [IntM "" (fromIntegral i)] - -instance LogFormatting Integer where - forMachine _dtal i = "val" .= AE.String ((pack . show) i) - forHuman = pack . show - asMetrics i = [IntM "" i] - --------------------------------------------------------------------------- -- Instances for 'TraceObject' to forward it using 'trace-forward' library. diff --git a/trace-dispatcher/src/Control/Tracer/Arrow.hs b/trace-dispatcher/src/Control/Tracer/Arrow.hs index 8db00668b22..907d4efa748 100644 --- a/trace-dispatcher/src/Control/Tracer/Arrow.hs +++ b/trace-dispatcher/src/Control/Tracer/Arrow.hs @@ -36,6 +36,7 @@ data TracerA m a b where -- | The resulting Kleisli arrow includes all of the effects required to do -- the emitting part. +{-# INLINE runTracerA #-} runTracerA :: Monad m => TracerA m a () -> Kleisli m a () runTracerA (Emitting emits _noEmits) = emits >>> arr (const ()) runTracerA (Squelching _ ) = arr (const ()) @@ -47,15 +48,18 @@ squelch = compute (const ()) -- | Do an emitting effect. Contrast with 'effect' which does not make the -- tracer an emitting tracer. +{-# INLINE emit #-} emit :: Applicative m => (a -> m ()) -> TracerA m a () emit f = Emitting (Kleisli f) (Kleisli (const (pure ()))) -- | Do a non-emitting effect. This effect will only be run if some part of -- the tracer downstream emits (see 'emit'). +{-# INLINE effect #-} effect :: (a -> m b) -> TracerA m a b effect = Squelching . Kleisli -- | Pure computation in a tracer: no side effects or emits. +{-# INLINE compute #-} compute :: Applicative m => (a -> b) -> TracerA m a b compute f = effect (pure . f) From 507793dc9fba627fc5a9562775859d33a79111f0 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Thu, 19 Oct 2023 15:32:19 +0200 Subject: [PATCH 04/11] trace-resources: temporal NetIO removal --- .../src/Cardano/Logging/Resources/Linux.hs | 33 ++++++++++++++----- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/trace-resources/src/Cardano/Logging/Resources/Linux.hs b/trace-resources/src/Cardano/Logging/Resources/Linux.hs index fd699f63284..c18e6fe6701 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Linux.hs +++ b/trace-resources/src/Cardano/Logging/Resources/Linux.hs @@ -82,15 +82,30 @@ readProcBlockInOut = do -- IpExt: 0 0 20053 8977 2437 23 3163525943 196480057 2426648 1491754 394285 5523 0 3513269 0 217426 0 -- readProcNetInOut :: IO (Word64, Word64) -readProcNetInOut = do - fields <- words . lastline . lines <$> readFile "/proc/self/net/netstat" - case -- We're only interested in 'InOctets' & 'OutOctets': - fmap readMaybe . take 2 . drop 7 $ fields of - [Just netIn, Just netOut] -> pure (netIn, netOut) - _ -> pure (0, 0) - where - lastline ls | length ls == 4 = last ls -- ensures we read the fourth line - | otherwise = [] +readProcNetInOut = pure (0, 0) +-- do +-- fields <- words . lastline . lines <$> readFile "/proc/self/net/netstat" +-- case -- We're only interested in 'InOctets' & 'OutOctets': +-- fmap readMaybe . take 2 . drop 7 $ fields of +-- [Just netIn, Just netOut] -> pure (netIn, netOut) +-- _ -> pure (0, 0) +-- where +-- lastline ls | length ls == 4 = last ls -- ensures we read the fourth line +-- | otherwise = [] + +-- readProcNetInOut = do +-- ipexts0 <- words <$> lastline <$> lines <$> readFile (pathProcNet pid) +-- let ipexts1 = map (\i -> readMaybe i :: Maybe Integer) ipexts0 +-- return $ +-- if length ipexts1 >= 9 -- enough fields available +-- then mkCounters [("IpExt:InOctets", ipexts1 !! 7), ("IpExt:OutOctets", ipexts1 !! 8)] +-- else [] +-- where +-- lastline ls | length ls == 4 = last ls -- ensures we read the fourth line +-- | otherwise = [] +-- mkCounters = catMaybes . map (\(n,c) -> mkCounter n c) +-- mkCounter _n Nothing = Nothing +-- mkCounter n (Just i) = Just (Counter NetCounter (pack n) (Bytes $ fromInteger i)) -- | TODO we have to expand the |readMemStats| function -- to read full data from |proc| From f1ea4b459f63f6f8f7e0882d59ec2640ac801a54 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Wed, 1 Nov 2023 11:06:10 +0100 Subject: [PATCH 05/11] cardano-tracer: useContramapM' for stderrShowTracer cardano-tracer: udes contramapM --- cardano-tracer/src/Cardano/Tracer/MetaTrace.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs b/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs index 6dfbc1fb14c..cc32462ed4f 100644 --- a/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs +++ b/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs @@ -155,9 +155,8 @@ instance MetaTrace TracerTrace where ] stderrShowTracer :: Trace IO TracerTrace -stderrShowTracer = - Trace $ T.arrow $ T.emit $ - either (const $ pure ()) (Sys.hPrint Sys.stderr) . snd +stderrShowTracer = Trace $ T.arrow $ T.emit $ + (either (const $ pure ()) (Sys.hPrint Sys.stderr) . snd) stderrTracer :: Trace IO FormattedMessage stderrTracer = From 31bf5279ff826922c9e9f639524e76d57c25dd41 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Fri, 17 Nov 2023 15:05:16 +0100 Subject: [PATCH 06/11] cardano-node: Use contramapM for ForgeTracer fixes --- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 2 +- .../Tracing/Tracers/StartLeadershipCheck.hs | 48 +++++++++---------- 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 47a35d5e94a..6e6b26ce0f0 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -58,7 +58,7 @@ withAddedToCurrentChainEmptyLimited -> IO (Trace IO (ChainDB.TraceEvent blk)) withAddedToCurrentChainEmptyLimited tr = do ltr <- limitFrequency 1.25 "AddedToCurrentChainLimiter" mempty tr - routingTrace (selecting ltr) tr + pure $ routingTrace (selecting ltr) tr where selecting ltr diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs index ec99366a266..a6ee7048fe2 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs @@ -14,7 +14,6 @@ module Cardano.Node.Tracing.Tracers.StartLeadershipCheck import Cardano.Logging -import qualified "trace-dispatcher" Control.Tracer as T import Control.Concurrent.STM (atomically) import Data.IORef (readIORef) @@ -60,29 +59,30 @@ forgeTracerTransform :: => NodeKernelData blk -> Trace IO (ForgeTracerType blk) -> IO (Trace IO (ForgeTracerType blk)) -forgeTracerTransform nodeKern (Trace tr) = pure $ Trace $ T.arrow $ T.emit $ - \case - (lc, Right (Left slc@(TraceStartLeadershipCheck slotNo))) -> do - query <- mapNodeKernelDataIO - (\nk -> - (,,) - <$> nkQueryLedger (ledgerUtxoSize . ledgerState) nk - <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk - <*> nkQueryChain fragmentChainDensity nk) - nodeKern - case query of - SNothing -> T.traceWith tr (lc, Right (Left slc)) - SJust (utxoSize, delegMapSize, chainDensity) -> - let msg = TraceStartLeadershipCheckPlus - slotNo - utxoSize - delegMapSize - (fromRational chainDensity) - in T.traceWith tr (lc, Right (Right msg)) - (lc, Right a) -> - T.traceWith tr (lc, Right a) - (lc, Left control) -> - T.traceWith tr (lc, Left control) +forgeTracerTransform nodeKern (Trace tr) = + contramapM (Trace tr) + (\case + (lc, Right (Left slc@(TraceStartLeadershipCheck slotNo))) -> do + query <- mapNodeKernelDataIO + (\nk -> + (,,) + <$> nkQueryLedger (ledgerUtxoSize . ledgerState) nk + <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk + <*> nkQueryChain fragmentChainDensity nk) + nodeKern + case query of + SNothing -> pure (lc, Right (Left slc)) + SJust (utxoSize, delegMapSize, chainDensity) -> + let msg = TraceStartLeadershipCheckPlus + slotNo + utxoSize + delegMapSize + (fromRational chainDensity) + in pure (lc, Right (Right msg)) + (lc, Right a) -> + pure (lc, Right a) + (lc, Left control) -> + pure (lc, Left control)) nkQueryLedger :: IsLedger (LedgerState blk) From b45e1ef0076b863a5ea081f6606358bbc89fad5f Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Fri, 17 Nov 2023 16:41:01 +0100 Subject: [PATCH 07/11] trace-dispatcher: fixes stylish haskell fixes, example fixes --- .../examples/Examples/Aggregation.hs | 4 +-- trace-dispatcher/examples/Examples/EKG.hs | 2 +- trace-dispatcher/examples/Examples/Routing.hs | 10 +++--- trace-dispatcher/src/Cardano/Logging/Types.hs | 35 +++++++++---------- 4 files changed, 25 insertions(+), 26 deletions(-) diff --git a/trace-dispatcher/examples/Examples/Aggregation.hs b/trace-dispatcher/examples/Examples/Aggregation.hs index dafe9394a5f..fed652d0df2 100644 --- a/trace-dispatcher/examples/Examples/Aggregation.hs +++ b/trace-dispatcher/examples/Examples/Aggregation.hs @@ -50,8 +50,8 @@ instance MetaTrace BaseStats where emptyStats :: BaseStats emptyStats = BaseStats 0.0 100000000.0 (-100000000.0) 0 0.0 -calculate :: BaseStats -> LoggingContext -> Double -> BaseStats -calculate BaseStats{..} _ val = +calculate :: BaseStats -> LoggingContext -> Double -> IO BaseStats +calculate BaseStats{..} _ val = pure $ BaseStats val (min bsMin val) diff --git a/trace-dispatcher/examples/Examples/EKG.hs b/trace-dispatcher/examples/Examples/EKG.hs index 31c789086e4..75ee5742e7f 100644 --- a/trace-dispatcher/examples/Examples/EKG.hs +++ b/trace-dispatcher/examples/Examples/EKG.hs @@ -36,7 +36,7 @@ testEKG :: IO () testEKG = do server <- forkServer "localhost" 8000 tracer <- ekgTracer (Right server) - let formattedTracer = metricsFormatter "cardano" tracer + let formattedTracer = metricsFormatter tracer confState <- emptyConfigReflection configureTracers confState emptyTraceConfig [formattedTracer] loop (appendPrefixName "ekg1" formattedTracer) 1 diff --git a/trace-dispatcher/examples/Examples/Routing.hs b/trace-dispatcher/examples/Examples/Routing.hs index e8eb18f1d35..dd80ace042e 100644 --- a/trace-dispatcher/examples/Examples/Routing.hs +++ b/trace-dispatcher/examples/Examples/Routing.hs @@ -10,7 +10,7 @@ import Examples.TestObjects routingTracer1 :: (Monad m) => Trace m (TraceForgeEvent LogBlock) -> Trace m (TraceForgeEvent LogBlock) - -> m (Trace m (TraceForgeEvent LogBlock)) + -> Trace m (TraceForgeEvent LogBlock) routingTracer1 t1 t2 = routingTrace routingf (t1 <> t2) where routingf TraceStartLeadershipCheck {} = pure t1 @@ -19,8 +19,8 @@ routingTracer1 t1 t2 = routingTrace routingf (t1 <> t2) routingTracer2 :: (Monad m) => Trace m (TraceForgeEvent LogBlock) -> Trace m (TraceForgeEvent LogBlock) - -> m (Trace m (TraceForgeEvent LogBlock)) -routingTracer2 t1 t2 = pure (t1 <> t2) + -> Trace m (TraceForgeEvent LogBlock) +routingTracer2 t1 t2 = t1 <> t2 testRouting :: IO () testRouting = do @@ -30,8 +30,8 @@ testRouting = do let t2 = appendPrefixName "tracer2" tf confState <- emptyConfigReflection configureTracers confState emptyTraceConfig [t1, t2] - r1 <- routingTracer1 t1 t2 - r2 <- routingTracer2 t1 t2 + let r1 = routingTracer1 t1 t2 + r2 = routingTracer2 t1 t2 traceWith r1 message1 traceWith r1 message2 traceWith r2 message3 diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs index b3e9d085110..a5be95a4d61 100644 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -313,26 +313,26 @@ data FormattedMessage = data PreFormatted a = PreFormatted { - pfMessage :: ! a - , pfForHuman :: ! (Maybe Text) - , pfForMachine :: ! Text - , pfNamespace :: ! [Text] - , pfTimestamp :: ! Text - , pfTime :: ! UTCTime - , pfHostname :: ! HostName - , pfThreadId :: ! Text + pfMessage :: !a + , pfForHuman :: !(Maybe Text) + , pfForMachine :: !Text + , pfNamespace :: ![Text] + , pfTimestamp :: !Text + , pfTime :: !UTCTime + , pfHostname :: !HostName + , pfThreadId :: !Text } -- | Used as interface object for ForwarderTracer data TraceObject = TraceObject { - toHuman :: ! (Maybe Text) - , toMachine :: ! Text - , toNamespace :: ! [Text] - , toSeverity :: ! SeverityS - , toDetails :: ! DetailLevel - , toTimestamp :: ! UTCTime - , toHostname :: ! HostName - , toThreadId :: ! Text + toHuman :: !(Maybe Text) + , toMachine :: !Text + , toNamespace :: ![Text] + , toSeverity :: !SeverityS + , toDetails :: !DetailLevel + , toTimestamp :: !UTCTime + , toHostname :: !HostName + , toThreadId :: !Text } deriving (Eq, Show) -- | @@ -493,8 +493,7 @@ data LogDoc = LogDoc { emptyLogDoc :: Text -> [(Text, Text)] -> LogDoc emptyLogDoc d m = LogDoc d (Map.fromList m) [] Nothing Nothing Nothing [] [] [] [] False --- | Type for the functions foldTraceM and foldTraceM from module --- Cardano/Logging/Trace +-- | Type for the function foldTraceM from module Cardano/Logging/Trace newtype Folding a b = Folding b unfold :: Folding a b -> b From 886244117a5176398fc12634a1a0db30d43101cc Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Mon, 20 Nov 2023 13:45:31 +0100 Subject: [PATCH 08/11] hlint fixes --- .../Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs | 1 - cardano-tracer/src/Cardano/Tracer/MetaTrace.hs | 2 +- trace-dispatcher/src/Cardano/Logging/Formatter.hs | 2 +- trace-dispatcher/src/Cardano/Logging/Trace.hs | 6 ++---- 4 files changed, 4 insertions(+), 7 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs index a6ee7048fe2..b3d5bb810a9 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PackageImports #-} module Cardano.Node.Tracing.Tracers.StartLeadershipCheck ( TraceStartLeadershipCheckPlus (..) diff --git a/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs b/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs index cc32462ed4f..9bba731ac17 100644 --- a/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs +++ b/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs @@ -155,7 +155,7 @@ instance MetaTrace TracerTrace where ] stderrShowTracer :: Trace IO TracerTrace -stderrShowTracer = Trace $ T.arrow $ T.emit $ +stderrShowTracer = Trace $ T.arrow $ T.emit (either (const $ pure ()) (Sys.hPrint Sys.stderr) . snd) stderrTracer :: Trace IO FormattedMessage diff --git a/trace-dispatcher/src/Cardano/Logging/Formatter.hs b/trace-dispatcher/src/Cardano/Logging/Formatter.hs index 474f9117087..0282d332775 100644 --- a/trace-dispatcher/src/Cardano/Logging/Formatter.hs +++ b/trace-dispatcher/src/Cardano/Logging/Formatter.hs @@ -36,7 +36,7 @@ import Network.HostName encodingToText :: AE.Encoding -> Text -{-# INLINE encodingToText#-} +{-# INLINE encodingToText #-} encodingToText = toStrict . decodeUtf8 . AE.encodingToLazyByteString -- | Format this trace as metrics diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs index 0fb10e9a25c..110ec99d335 100644 --- a/trace-dispatcher/src/Cardano/Logging/Trace.hs +++ b/trace-dispatcher/src/Cardano/Logging/Trace.hs @@ -37,7 +37,7 @@ module Cardano.Logging.Trace ( , withInnerNames ) where -import Control.Monad (join) +import Control.Monad (forM_, join) import Control.Monad.IO.Unlift import qualified Control.Tracer as T import Data.Maybe (isJust) @@ -307,9 +307,7 @@ contramapMCond (Trace tr) mFunc = where rFunc arg = do condMes <- mFunc arg - case condMes of - Nothing -> pure () - Just mes -> T.traceWith tr mes + forM_ condMes (T.traceWith tr) {-# INLINE contramapM' #-} contramapM' :: Monad m From 232f8075149590eb663111c6dde8dc60af848053 Mon Sep 17 00:00:00 2001 From: Michael Karg Date: Tue, 21 Nov 2023 12:45:22 +0100 Subject: [PATCH 09/11] trace-resources: optimize; add microbenchmark --- .../bench/trace-resources-bench.hs | 22 +++++++++++++++++++ .../src/Cardano/Logging/Resources/Linux.hs | 14 +++++++++--- trace-resources/trace-resources.cabal | 16 +++++++++++++- 3 files changed, 48 insertions(+), 4 deletions(-) create mode 100644 trace-resources/bench/trace-resources-bench.hs diff --git a/trace-resources/bench/trace-resources-bench.hs b/trace-resources/bench/trace-resources-bench.hs new file mode 100644 index 00000000000..57509904db9 --- /dev/null +++ b/trace-resources/bench/trace-resources-bench.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} + +import Criterion.Main +import Criterion.Types + + +#if defined(linux_HOST_OS) +import qualified Cardano.Logging.Resources.Linux as Platform +#elif defined(mingw32_HOST_OS) +import qualified Cardano.Logging.Resources.Windows as Platform +#elif defined(darwin_HOST_OS) +import qualified Cardano.Logging.Resources.Darwin as Platform +#else +import qualified Cardano.Logging.Resources.Dummy as Platform +#endif + + +main :: IO () +main = + defaultMainWith defaultConfig{ timeLimit = 15 } + [ bench "create record ResourceStats" (whnfIO Platform.readResourceStatsInternal) + ] diff --git a/trace-resources/src/Cardano/Logging/Resources/Linux.hs b/trace-resources/src/Cardano/Logging/Resources/Linux.hs index c18e6fe6701..0c02a9be047 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Linux.hs +++ b/trace-resources/src/Cardano/Logging/Resources/Linux.hs @@ -8,10 +8,12 @@ module Cardano.Logging.Resources.Linux import Cardano.Logging.Resources.Types import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T (readFile) +import qualified Data.Text.Read as T (decimal) import Data.Word import qualified GHC.Stats as GhcStats import System.Posix.Files (fileMode, getFileStatus, intersectFileModes, ownerReadMode) -import Text.Read (readMaybe) -- * Disk IO stats: -- /proc/[pid]/io (since kernel 2.6.20) @@ -146,9 +148,15 @@ readProcList fp = do fs <- getFileStatus fp if readable fs then do - cs <- readFile fp - return $ map (\s -> fromMaybe 0 (readMaybe s :: Maybe Integer)) (words cs) + cs <- T.readFile fp + return $ map (fromMaybe 0 . readMaybeText) (T.words cs) else return [] where readable fs = intersectFileModes (fileMode fs) ownerReadMode == ownerReadMode + +readMaybeText :: Integral a => T.Text -> Maybe a +readMaybeText t = + case T.decimal t of + Right (v, _) -> Just v + _ -> Nothing diff --git a/trace-resources/trace-resources.cabal b/trace-resources/trace-resources.cabal index e48db579c60..fe3e6deac01 100644 --- a/trace-resources/trace-resources.cabal +++ b/trace-resources/trace-resources.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: trace-resources -version: 0.2.0.2 +version: 0.2.1.0 synopsis: Package for tracing resources for linux, mac and windows description: Package for tracing resources for linux, mac and windows. category: Cardano, @@ -84,3 +84,17 @@ test-suite trace-resources-test -Wredundant-constraints -Wmissing-export-lists -Wno-incomplete-patterns + +benchmark bench + import: project-config + type: exitcode-stdio-1.0 + main-is: trace-resources-bench.hs + hs-source-dirs: bench + build-depends: base >=4.12 && <5 + , criterion + , trace-resources + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Wunused-packages -threaded -rtsopts -O2 + "-with-rtsopts=-T" From fb6a311de587ed3721538434d688524d2b2e2c95 Mon Sep 17 00:00:00 2001 From: Michael Karg Date: Tue, 21 Nov 2023 17:02:01 +0100 Subject: [PATCH 10/11] trace-resources: version 0.2.1.0; conditional compilation for netstat values --- trace-resources/CHANGELOG.md | 8 +++- .../src/Cardano/Logging/Resources/Linux.hs | 43 ++++++++----------- trace-resources/trace-resources.cabal | 9 ++++ 3 files changed, 33 insertions(+), 27 deletions(-) diff --git a/trace-resources/CHANGELOG.md b/trace-resources/CHANGELOG.md index 641629c3477..66a5b636a80 100644 --- a/trace-resources/CHANGELOG.md +++ b/trace-resources/CHANGELOG.md @@ -1,4 +1,10 @@ -# Revision history for trace-dispatcher +# Revision history for trace-resources + +## 0.2.1.0 -- Nov 2023 + +* Optimized resource record creation on Linux +* Add microbenchmark for resource record creation +* Add cabal flag `with-netstat` (default: False) to enable netstat values in Linux resource traces (potentially expensive) ## 0.2.0.2 -- Sep 2023 diff --git a/trace-resources/src/Cardano/Logging/Resources/Linux.hs b/trace-resources/src/Cardano/Logging/Resources/Linux.hs index 0c02a9be047..7f560905150 100644 --- a/trace-resources/src/Cardano/Logging/Resources/Linux.hs +++ b/trace-resources/src/Cardano/Logging/Resources/Linux.hs @@ -8,9 +8,9 @@ module Cardano.Logging.Resources.Linux import Cardano.Logging.Resources.Types import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import qualified Data.Text.IO as T (readFile) -import qualified Data.Text.Read as T (decimal) +import qualified Data.Text as T +import qualified Data.Text.IO as T (readFile) +import qualified Data.Text.Read as T (decimal) import Data.Word import qualified GHC.Stats as GhcStats import System.Posix.Files (fileMode, getFileStatus, intersectFileModes, ownerReadMode) @@ -84,30 +84,21 @@ readProcBlockInOut = do -- IpExt: 0 0 20053 8977 2437 23 3163525943 196480057 2426648 1491754 394285 5523 0 3513269 0 217426 0 -- readProcNetInOut :: IO (Word64, Word64) +#ifdef WITH_NETSTAT +readProcNetInOut = do + fields <- T.words . fourthLine . T.lines <$> T.readFile "/proc/self/net/netstat" + case -- We're only interested in 'InOctets' & 'OutOctets': + fmap readMaybeText . take 2 . drop 7 $ fields of + [Just netIn, Just netOut] -> pure (netIn, netOut) + _ -> pure (0, 0) + where + -- Assumption: 'IpExt:' values are on the fourth line of how the kernel displays the buffer + fourthLine ls = case drop 3 ls of + l:_ -> l + _ -> T.empty +#else readProcNetInOut = pure (0, 0) --- do --- fields <- words . lastline . lines <$> readFile "/proc/self/net/netstat" --- case -- We're only interested in 'InOctets' & 'OutOctets': --- fmap readMaybe . take 2 . drop 7 $ fields of --- [Just netIn, Just netOut] -> pure (netIn, netOut) --- _ -> pure (0, 0) --- where --- lastline ls | length ls == 4 = last ls -- ensures we read the fourth line --- | otherwise = [] - --- readProcNetInOut = do --- ipexts0 <- words <$> lastline <$> lines <$> readFile (pathProcNet pid) --- let ipexts1 = map (\i -> readMaybe i :: Maybe Integer) ipexts0 --- return $ --- if length ipexts1 >= 9 -- enough fields available --- then mkCounters [("IpExt:InOctets", ipexts1 !! 7), ("IpExt:OutOctets", ipexts1 !! 8)] --- else [] --- where --- lastline ls | length ls == 4 = last ls -- ensures we read the fourth line --- | otherwise = [] --- mkCounters = catMaybes . map (\(n,c) -> mkCounter n c) --- mkCounter _n Nothing = Nothing --- mkCounter n (Just i) = Just (Counter NetCounter (pack n) (Bytes $ fromInteger i)) +#endif -- | TODO we have to expand the |readMemStats| function -- to read full data from |proc| diff --git a/trace-resources/trace-resources.cabal b/trace-resources/trace-resources.cabal index fe3e6deac01..a1b35f2ce80 100644 --- a/trace-resources/trace-resources.cabal +++ b/trace-resources/trace-resources.cabal @@ -17,6 +17,11 @@ extra-source-files: include/os-support-darwin.h extra-doc-files: CHANGELOG.md README.md +Flag with-netstat + Description: Enable netstat values in Linux resource traces (potentially expensive) + Manual: True + Default: False + common project-config default-language: Haskell2010 @@ -28,6 +33,7 @@ library Cardano.Logging.Resources.Dummy default-extensions: OverloadedStrings + CPP build-depends: base >=4.12 && <5 , trace-dispatcher , text @@ -48,6 +54,9 @@ library -Wmissing-export-lists -Wno-incomplete-patterns + if flag(with-netstat) + CPP-options: -DWITH_NETSTAT + if os(linux) exposed-modules: Cardano.Logging.Resources.Linux if os(windows) From 010dda7d5b4b768a971d69e757b8800a8876f0b8 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Thu, 23 Nov 2023 12:32:57 +0100 Subject: [PATCH 11/11] trace-dispatcher: review changes --- trace-dispatcher/src/Cardano/Logging/Trace.hs | 3 --- trace-dispatcher/src/Cardano/Logging/Types.hs | 4 ---- 2 files changed, 7 deletions(-) diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs index 110ec99d335..2c3fb3a0ced 100644 --- a/trace-dispatcher/src/Cardano/Logging/Trace.hs +++ b/trace-dispatcher/src/Cardano/Logging/Trace.hs @@ -181,7 +181,6 @@ withSeverity (Trace tr) = Trace $ (lc, Left e) -> (lc, Left e)) tr where - {-# INLINE process #-} process lc cont@(Right v) = if isJust (lcSeverity lc) then (lc,cont) @@ -236,7 +235,6 @@ withPrivacy (Trace tr) = Trace $ (lc, Left e) -> (lc, Left e)) tr where - {-# INLINE process #-} process lc cont@(Right v) = if isJust (lcPrivacy lc) then (lc,cont) @@ -268,7 +266,6 @@ withDetails (Trace tr) = Trace $ (lc, Left e) -> (lc, Left e)) tr where - {-# INLINE process #-} process lc cont@(Right v) = if isJust (lcDetails lc) then (lc,cont) diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs index a5be95a4d61..6374b697a8b 100644 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -53,7 +53,6 @@ module Cardano.Logging.Types ( import Codec.Serialise (Serialise (..)) --- import Data.Aeson ((.=)) import qualified Data.Aeson as AE import qualified Data.HashMap.Strict as HM import Data.IORef @@ -68,12 +67,9 @@ import Network.HostName (HostName) import qualified Control.Tracer as T --- - import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) - -- | The Trace carries the underlying tracer Tracer from the contra-tracer package. -- It adds a 'LoggingContext' and maybe a 'TraceControl' to every message. newtype Trace m a = Trace