Merge pull request #6409 from IntersectMBO/mkarg/tracing-improvements

new tracing: various improvements

Author: mgmeier

cardano-node/src/Cardano/Node/Tracing/DefaultTraceConfig.hs

@@ -17,9 +17,8 @@ defaultCardanoConfig = emptyTraceConfig {
      [([],
           [ ConfSeverity (SeverityF (Just Notice))
           , ConfDetail DNormal
-          , ConfBackend  [Stdout MachineFormat
+          , ConfBackend  [ Stdout MachineFormat
                          , EKGBackend
-                         , Forwarder
                          ]])
 
      -- more important tracers going here

cardano-tracer/test/cardano-tracer-test-ext.hs

@@ -138,7 +138,8 @@ getExternalTracerState TestSetup{..} ref = do
        -- For simplicity, we are always 'Initiator',
        -- so 'cardano-tracer' is always a 'Responder'.
        let forwardingConf = fromMaybe defaultForwarder (tcForwarder simpleTestConfig)
-       initForwarding iomgr forwardingConf $
+       -- weaker machines (like CI runners) need to be able to buffer more trace objects for the stress test
+       initForwarding iomgr forwardingConf{ tofQueueSize = 768 } $
          InitForwardingWith
            { initNetworkMagic          = unI tsNetworkMagic
            , initEKGStore              = Nothing

trace-dispatcher/CHANGELOG.md

@@ -1,8 +1,11 @@
 # Revision history for trace-dispatcher
 
-## 2.11.1 -- Dez 2025
+## 2.11.1 -- Jan 2026
 
+* Add strict `contramap'` (infix alias `>!$!<`) to the API, capturing a common pattern to avoid unintentional space leaks when composing tracers
 * Increase `PrometheusSimple` robustness by restarting the backend upon crash, adding start/stop traces and more eagerly reaping of dangling sockets
+* Increased strictness when storing traced `DataPoints`
+* Drastically reduced fallback value for forwarding queue capacity to minimize impact of forwarding service interruption on heap size and retention
 * Removed `TraceConfig.tcPeerFrequency` and hence `TraceOptionPeerFrequency` from config representation
 * Removed unused module `Cardano.Logging.Types.NodePeers`
 

trace-dispatcher/src/Cardano/Logging/Trace.hs

@@ -34,13 +34,17 @@ module Cardano.Logging.Trace (
   , appendInnerName
   , appendInnerNames
   , withInnerNames
+
+  , contramap'
+  , (>!$!<)
   ) where
 
 import           Cardano.Logging.Types
 
 import           Control.Monad (forM_, join)
 import           Control.Monad.IO.Unlift
 import qualified Control.Tracer as T
+import           Data.Functor.Contravariant as Contr (Contravariant, (>$<))
 import           Data.Maybe (isJust)
 import           Data.Text (Text)
 
@@ -371,3 +375,15 @@ routingTrace rf rc = contramapM'
       (lc, Left control) ->
           T.traceWith (unpackTrace rc) (lc, Left control))
 
+-- | A contramap' which is strict in its second argument and its result captures
+--   a common pattern to avoid unintentionally leaking space when composing tracers.
+--   The infix alias is (>!$!<).
+contramap', (>!$!<) :: Contravariant f => (a' -> a) -> (f a -> f a')
+
+contramap' a !b =
+  let !result = a Contr.>$< b
+  in result
+
+infixl 4 >!$!<
+
+(>!$!<) = contramap'

trace-dispatcher/src/Cardano/Logging/Tracer/DataPoint.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -21,7 +22,7 @@ import           Cardano.Logging.Types
 
 import           Control.Concurrent.STM (atomically)
 import           Control.Concurrent.STM.TVar
-import           Control.DeepSeq (NFData, deepseq)
+import           Control.DeepSeq (NFData, ($!!))
 import           Control.Monad.IO.Class
 import qualified Control.Tracer as NT
 import           Data.Aeson
@@ -39,11 +40,12 @@ import           Data.Text (Text, intercalate)
 --   available for the acceptor application, to decode unstructured JSON.
 --
 data DataPoint where
-  DataPoint :: (ToJSON v, NFData v) => v -> DataPoint
+  DataPoint :: (ToJSON v, NFData v) => !v -> DataPoint
 
-type DataPointName   = Text
+type DataPointName  = Text
 type DataPointStore = TVar (M.Map DataPointName DataPoint)
 
+
 initDataPointStore :: IO DataPointStore
 initDataPointStore = newTVarIO M.empty
 
@@ -53,11 +55,11 @@ writeToStore
   -> DataPointName
   -> DataPoint
   -> IO ()
-writeToStore dpStore dpName (DataPoint obj) = atomically $
-  modifyTVar' dpStore $ \store ->
-    if dpName `M.member` store
-      then M.adjust (const (DataPoint (deepseq obj obj))) dpName store
-      else M.insert dpName (DataPoint (deepseq obj obj)) store
+writeToStore dpStore dpName (DataPoint obj) =
+  let !newVal = DataPoint $!! obj
+  in atomically $
+      modifyTVar' dpStore $
+        M.insert dpName newVal
 
 dataPointTracer :: forall m. MonadIO m
   => DataPointStore

trace-dispatcher/src/Cardano/Logging/Types.hs

@@ -497,7 +497,7 @@ data TraceOptionForwarder = TraceOptionForwarder {
 -- requests periodically, the default for that being 100. Here, the queue can
 -- hold enough traces for 10 subsequent polls by cardano-tracer.
 instance AE.FromJSON TraceOptionForwarder where
-    parseJSON (AE.Object obj) = do
+    parseJSON = AE.withObject "TraceOptionForwarder" $ \obj -> do
       -- Field "queueSize" is the new field that replaces and unifies
       -- both "connQueueSize" and "disconnQueueSize".
       maybeQueueSize <- obj AE..:? "queueSize"
@@ -506,14 +506,12 @@ instance AE.FromJSON TraceOptionForwarder where
                      (Just qs) -> return qs
                      -- Else we look for the deprectaed fields.
                      Nothing   -> do
-                       -- We keep the same default values.
-                       connQueueSize    <- obj AE..:? "connQueueSize"    AE..!= 1024
-                       disconnQueueSize <- obj AE..:? "disconnQueueSize" AE..!= 2048
+                       connQueueSize    <- obj AE..:? "connQueueSize"    AE..!= 128
+                       disconnQueueSize <- obj AE..:? "disconnQueueSize" AE..!= 192
                        return $ max connQueueSize disconnQueueSize
       verbosity         <- obj AE..:? "verbosity"         AE..!= Minimum
-      maxReconnectDelay <- obj AE..:? "maxReconnectDelay" AE..!= 60
+      maxReconnectDelay <- obj AE..:? "maxReconnectDelay" AE..!= 45
       return $ TraceOptionForwarder queueSize verbosity maxReconnectDelay
-    parseJSON _ = mempty
 
 instance AE.ToJSON TraceOptionForwarder where
   toJSON TraceOptionForwarder{..} = AE.object
@@ -525,9 +523,9 @@ instance AE.ToJSON TraceOptionForwarder where
 
 defaultForwarder :: TraceOptionForwarder
 defaultForwarder = TraceOptionForwarder {
-    tofQueueSize           = 2048
+    tofQueueSize           = 192
   , tofVerbosity           = Minimum
-  , tofMaxReconnectDelay   = 60
+  , tofMaxReconnectDelay   = 45
 }
 
 instance AE.FromJSON ForwarderMode where