Merge pull request IntersectMBO#5541 from input-output-hk/jutaro/trac…

…er-open-ends Optimize new tracing further
Emurgo · Nov 24, 2023 · 49e39d2 · 49e39d2
2 parents 34d89af + 010dda7
commit 49e39d2
Show file tree

Hide file tree

Showing 22 changed files with 454 additions and 398 deletions.
diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs
@@ -244,8 +244,8 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf
 
     -- Special blockFetch client metrics, send directly to EKG
     !blockFetchClientMetricsTr <- do
-        tr1 <- foldMTraceM calculateBlockFetchClientMetrics initialClientMetrics
-                    (metricsFormatter ""
+        tr1 <- foldTraceM calculateBlockFetchClientMetrics initialClientMetrics
+                    (metricsFormatter
                       (mkMetricsTracer mbTrEKG))
         pure $ filterTrace (\ (_, TraceLabelPeer _ m) -> case m of
                                               BlockFetch.CompletedBlockFetch {} -> True

diff --git 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/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/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

diff --git 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 (..)
@@ -14,7 +13,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 +58,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)

diff --git 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 =

diff --git 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/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
@@ -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
@@ -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