trace-dispatcher: maintenance (#12)

* trace-dispatcher: maintenance pass

* trace-dispatcher: additional resilience for some code paths

Author: mgmeier

trace-dispatcher/CHANGELOG.md

@@ -8,6 +8,11 @@
 * Snoc a namespace separator `.` to the metrics prefix config value when missing.
 * Provide `Cardano.Logging.Prometheus.Exposition.asPrometheusMetricName`, creating an external (Prometheus naming schemal compliant) metric name from an internal one.
 * Rename `NodeStartupInfo.suiEra` to `suiLatestSupportedEra`.
+* `TCPServer.hs`: `Content-Length` is now computed from byte count of the UTF-8 encoded body, not the character count.
+* `TracerInfoConfig` namespace form is now identical to constructor.
+* Limiter name is now included in the machine-readable trace output for high detail levels.
+* New exception type `HermodException` - currently only used for config errors.
+* Safeguard ceiling for PrometheusSimple response size, corresponding to roughly 56,000 distinct application metrics.
 
 ## 2.12.1 -- Apr 2026
 

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

@@ -5,6 +5,7 @@
 
 module Cardano.Logging.Configuration
   ( ConfigReflection (..)
+  , HermodException(..)
   , emptyConfigReflection
   , configureTracers
   , withNamespaceConfig
@@ -28,18 +29,27 @@ import           Cardano.Logging.Trace
 import           Cardano.Logging.TraceDispatcherMessage
 import           Cardano.Logging.Types
 
+import           Control.Applicative (asum)
+import           Control.Exception
 import           Control.Monad (unless)
 import           Control.Monad.IO.Class (MonadIO, liftIO)
 import           Control.Monad.IO.Unlift (MonadUnliftIO)
 import qualified Control.Tracer as T
 import           Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
-import           Data.List (maximumBy, nub)
-import qualified Data.Map as Map
-import           Data.Maybe (fromMaybe, mapMaybe)
+import           Data.List (inits, maximumBy, nub)
+import qualified Data.Map.Lazy as Map
+import           Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
 import qualified Data.Set as Set
 import           Data.Text (Text, intercalate, unpack)
 
 
+-- This is currently ad-hoc. With a future refactoring of trace-dispatcher,
+-- it will be moved and serve as a proper error / exception type.
+data HermodException = HermodConfigException { excMessage :: String }
+     deriving Show
+
+instance Exception HermodException
+
 -- | Call this function at initialisation, and later for reconfiguration.
 -- Config reflection is used to optimise the tracers and has to collect
 -- information about the tracers. Although it is possible to give more then
@@ -153,6 +163,7 @@ withNamespaceConfig name extract withConfig tr = do
     ref  <- liftIO (newIORef (Left (Map.empty, Nothing)))
     pure $ contramapM' (mapFunc ref)
   where
+    configError = liftIO . throwIO . HermodConfigException
     mapFunc ref =
       \case
         (lc, Right a) -> do
@@ -192,11 +203,11 @@ withNamespaceConfig name extract withConfig tr = do
                     then do
                       Trace tt <- withConfig (Just val) tr
                       T.traceWith tt (lc, Left (TCConfig c))
-                    else error $ "Inconsistent trace configuration with context "
+                    else configError $ "Inconsistent trace configuration with context "
                                       ++ show nst
-            Right _val -> error $ "Trace not reset before reconfiguration (1)"
+            Right _val -> configError $ "Trace not reset before reconfiguration (1)"
                                 ++ show nst
-            Left (_cmap, Just _v) -> error $ "Trace not reset before reconfiguration (2)"
+            Left (_cmap, Just _v) -> configError $ "Trace not reset before reconfiguration (2)"
                                 ++ show nst
         (lc, Left (TCOptimize cr)) -> do
           eitherConf <- liftIO $ readIORef ref
@@ -222,10 +233,10 @@ withNamespaceConfig name extract withConfig tr = 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)"
+            Right _val -> configError $ "Trace not reset before reconfiguration (3)"
                                 ++ show nst
             Left (_cmap, Just _v) ->
-                          error $ "Trace not reset before reconfiguration (4)"
+                          configError $ "Trace not reset before reconfiguration (4)"
                                       ++ show nst
         (lc, Left dc@TCDocument {}) -> do
           eitherConf <- liftIO $ readIORef ref
@@ -243,7 +254,7 @@ withNamespaceConfig name extract withConfig tr = do
                     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)
+            Left (_cmap, Nothing) -> configError $ "Missing configuration(2) " <> name <> " ns " <> show nst
 
 
 -- | Filter a trace by severity and take the filter value from the config
@@ -253,7 +264,7 @@ filterSeverityFromConfig :: (MonadIO m) =>
 filterSeverityFromConfig =
     withNamespaceConfig
       "severity"
-      getSeverity'
+      (\conf -> pure . getSeverity conf)
       (\sev tr -> contramapMCond tr (mapF sev))
   where
     mapF confSev =
@@ -282,7 +293,7 @@ withDetailsFromConfig :: (MonadIO m) =>
 withDetailsFromConfig =
   withNamespaceConfig
     "details"
-    getDetails'
+    (\conf -> pure . getDetails conf)
     (\mbDtl b -> case mbDtl of
               Just dtl -> pure $ setDetails dtl b
               Nothing  -> pure $ setDetails DNormal b)
@@ -294,7 +305,7 @@ withBackendsFromConfig :: (MonadIO m) =>
 withBackendsFromConfig rappendPrefixNameAndFormatter =
   withNamespaceConfig
     "backends"
-    getBackends'
+    (\conf -> pure . getBackends conf)
     rappendPrefixNameAndFormatter
     (Trace T.nullTracer)
 
@@ -377,9 +388,6 @@ getSeverity config ns =
     severitySelector (ConfSeverity s) = Just s
     severitySelector _              = Nothing
 
-getSeverity' :: Applicative m => TraceConfig -> Namespace a -> m SeverityF
-getSeverity' config ns = pure $ getSeverity config ns
-
 -- | If no details can be found in the config, it is set to DNormal
 getDetails :: TraceConfig -> Namespace a -> DetailLevel
 getDetails config ns =
@@ -389,9 +397,6 @@ getDetails config ns =
     detailSelector (ConfDetail d) = Just d
     detailSelector _            = Nothing
 
-getDetails' :: Applicative m => TraceConfig -> Namespace a -> m DetailLevel
-getDetails' config n = pure $ getDetails config n
-
 -- | If no backends can be found in the config, it is set to
 -- [EKGBackend, Forwarder, Stdout HumanFormatColoured]
 getBackends :: TraceConfig -> Namespace a -> [BackendConfig]
@@ -403,9 +408,6 @@ getBackends config ns =
     backendSelector (ConfBackend s) = Just s
     backendSelector _             = Nothing
 
-getBackends' :: Applicative m => TraceConfig -> Namespace a -> m [BackendConfig]
-getBackends' config ns = pure $ getBackends config ns
-
 -- | May return a limiter specification
 getLimiterSpec :: TraceConfig -> Namespace a -> Maybe (Text, Double)
 getLimiterSpec config ns = getOption limiterSelector config (nsGetComplete ns)
@@ -414,17 +416,10 @@ getLimiterSpec config ns = getOption limiterSelector config (nsGetComplete ns)
     limiterSelector (ConfLimiter f) = Just (intercalate "." (nsPrefix ns ++ nsInner ns), f)
     limiterSelector _               = Nothing
 
--- | Searches in the config to find an option
+-- | Searches in the config to find an option, most-specific as per namespace first.
+-- (Generates all ancestor prefixes once via `inits`, avoiding a repeated O(n) `init` call at each recursion level)
 getOption :: (ConfigOption -> Maybe a) -> TraceConfig -> [Text] -> Maybe a
-getOption sel config [] =
-  case Map.lookup [] (tcOptions config) of
-    Nothing -> Nothing
-    Just options -> case mapMaybe sel options of
-                      []        -> Nothing
-                      (opt : _) -> Just opt
-getOption sel config ns =
-  case Map.lookup ns (tcOptions config) of
-    Nothing -> getOption sel config (init ns)
-    Just options -> case mapMaybe sel options of
-                      []        -> getOption sel config (init ns)
-                      (opt : _) -> Just opt
+getOption sel TraceConfig{tcOptions} ns =
+  asum $ map tryLookup $ reverse $ inits ns
+  where
+    tryLookup k = listToMaybe . mapMaybe sel =<< Map.lookup k tcOptions

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

@@ -88,6 +88,8 @@ instance AE.ToJSON ConfigRepresentation where
     , "ApplicationName"          .= traceOptionNodeName
     , "MetricsPrefix"            .= traceOptionMetricsPrefix
     , "PrometheusSimpleRun"      .= tracePrometheusSimpleRun
+    -- Both *Frequency fields are scheduled for removal from the data type.
+    -- The current data loss on round-trip wrt. `parseAsLegacy` above is deliberate.
     ]
 
 type OptionsRepresentation = Map.Map Text ConfigOptionRep

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

@@ -50,10 +50,11 @@ import           Data.Text                           as T (Text, empty,
                                                            intercalate, lines,
                                                            pack, stripPrefix,
                                                            toLower, unlines)
-import           Data.Text.Internal.Builder          (toLazyText)
+import qualified Data.Text                           as T (null)
 import           Data.Text.Lazy                      (toStrict)
 import           Data.Text.Lazy.Builder              (Builder, fromString,
-                                                      fromText, singleton)
+                                                      fromText, singleton,
+                                                      toLazyText)
 import           Data.Tree                           (Forest, Tree (..),
                                                       unfoldForest)
 
@@ -568,6 +569,8 @@ generateTOC DocTracer {..} traces metrics datapoints =
         link = mconcat (map (fromText . toLower) firstTracer)
 
         -- The first tracer in the list of tracers that has that namespace prefix
+        -- Safe: the tree is constructed from allTracers via toForest (and trim, which
+        -- preserves the invariant), so ns is always a prefix of some element in allTracers.
         firstTracer :: [Text]
         firstTracer = fromJust $ find (ns `isPrefixOf`) allTracers
 
@@ -576,15 +579,13 @@ asCode :: Builder -> Builder
 asCode b = singleton '`' <> b <> singleton '`'
 
 accentuated :: Text -> Builder
-accentuated t = if t == ""
-                  then fromText "\n"
-                  else fromText "\n"
-                        <> fromText (unlines $ map addAccent (lines t))
+accentuated t =
+     singleton '\n'
+  <> mconcat (map (\l -> addAccent l <> singleton '\n') (T.lines t))
   where
-    addAccent :: Text -> Text
-    addAccent t' = if t' == ""
-                    then ">"
-                    else "> " <> t'
+    addAccent l
+      | T.null l  = singleton '>'
+      | otherwise = fromText "> " <> fromText l
 
 -- Convert a list of namespaces to a tree representation
 toForest :: [[Text]] -> Forest Text

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

@@ -1,6 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -46,6 +44,8 @@ import           System.IO.Unsafe (unsafePerformIO)
 -- | If the @TRACE_DISPATCHER_LOGGING_HOSTNAME@ environment variable is set,
 --   it overrides the system hostname in the trace message. This is useful when
 --   multiple instances of a service or application on the same host.
+-- 
+--   The env var is expected to be set (if desired) before the application emits its first trace, as this is evaluated only once.
 hostname :: Text
 {-# NOINLINE hostname #-}
 hostname = unsafePerformIO $
@@ -246,8 +246,9 @@ colorBySeverity withColor severity' msg =
 
 humanFormatter
   :: forall a m .
-     MonadIO m
-  => LogFormatting a
+     ( MonadIO m
+     , LogFormatting a
+     )
   => Bool
   -> Trace m FormattedMessage
   -> m (Trace m a)
@@ -256,26 +257,29 @@ humanFormatter withColor =
 
 machineFormatter
   :: forall a m .
-     (MonadIO m
-  ,  LogFormatting a)
+     ( MonadIO m
+     , LogFormatting a
+     )
   => Trace m FormattedMessage
   -> m (Trace m a)
 machineFormatter =
   preFormatted False . machineFormatter'
 
 cborFormatter
   :: forall a m .
-     (MonadIO m
-  ,  LogFormatting a)
+     ( MonadIO m
+     , LogFormatting a
+     )
   => Trace m FormattedMessage
   -> m (Trace m a)
 cborFormatter =
   preFormatted False . cborFormatter'
 
 forwardFormatter
   :: forall a m .
-     MonadIO m
-  => LogFormatting a
+     ( MonadIO m
+     , LogFormatting a
+     )
   => Trace m FormattedMessage
   -> m (Trace m a)
 forwardFormatter =

trace-dispatcher/src/Cardano/Logging/Prometheus/NetworkRun.hs

@@ -3,9 +3,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-
-
 -- | Run a TCP server, with hardening against connection flooding
 module Cardano.Logging.Prometheus.NetworkRun
        ( NetworkRunParams (..)
@@ -25,7 +22,6 @@ import           Control.Monad (forever, void, when)
 import qualified Data.Foldable as F (sum)
 import           Data.Hashable (hash)
 import qualified Data.IntMap.Strict as IM
-import qualified Data.List.NonEmpty as NE
 import           Data.Maybe (fromMaybe)
 import           Network.Socket
 import qualified System.TimeManager as T

trace-dispatcher/src/Cardano/Logging/Prometheus/TCPServer.hs

@@ -23,13 +23,14 @@ import           Data.Aeson.Types as AE (Value (String), (.=))
 import           Data.ByteString (ByteString)
 import           Data.ByteString.Builder
 import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy.Char8 as BCL (length)
 import           Data.Int (Int64)
 import           Data.List (find, intersperse)
 import           Data.Maybe (fromMaybe)
 import           Data.Text as TS (pack)
 import           Data.Text.Lazy (Text)
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Encoding as T (encodeUtf8Builder)
+import qualified Data.Text.Lazy as TL (length)
+import qualified Data.Text.Lazy.Encoding as T (encodeUtf8)
 import           Data.Word (Word16)
 import           Network.HTTP.Date (epochTimeToHTTPDate, formatHTTPDate)
 import           Network.Socket (HostName, PortNumber)
@@ -158,11 +159,17 @@ hdrContentTypeOpenMetrics = "Content-Type: application/openmetrics-text;version=
 hdrContentLength :: Int64 -> Builder
 hdrContentLength len = "Content-Length: " <> int64Dec len
 
-errorBadRequest, errorNotFound, errorBadMethod, errorBadContent :: (ByteString, ByteString)
-errorBadRequest = ("400", "Bad Request")
-errorNotFound   = ("404", "Not Found")
-errorBadMethod  = ("405", "Method Not Allowed")
-errorBadContent = ("415", "Unsupported Media Type")
+errorBadRequest, errorNotFound, errorBadMethod, errorBadContent, errorPayloadTooLarge :: (ByteString, ByteString)
+errorBadRequest    = ("400", "Bad Request")
+errorNotFound      = ("404", "Not Found")
+errorBadMethod     = ("405", "Method Not Allowed")
+errorBadContent    = ("415", "Unsupported Media Type")
+errorPayloadTooLarge = ("503", "Service Unavailable")
+
+-- 8 MB ceiling as a safeguard for response size - this should never fire.
+-- Corresponds to roughly 56.000 distinct application metrics: a legitimate exposition should be well under this!
+maxResponseChars :: Int64
+maxResponseChars = 8 * 1024 * 1024
 
 -- HTTP header line break
 nl :: Builder
@@ -185,14 +192,19 @@ responseError withBody (errCode, errMsg) =
     msg = errCode <> " " <> errMsg
 
 responseMessage :: Bool -> Builder -> Text -> EpochTime -> Builder
-responseMessage withBody contentType msg now =
-  mconcat $ intersperse nl
-    [ "HTTP/1.1 200 OK"
-    , hdrContentLength (T.length msg)
-    , contentType
-    , "Date: " <> byteString httpDate
-    , ""
-    , if withBody then T.encodeUtf8Builder msg else ""
-    ]
-    where
-      httpDate = formatHTTPDate $ epochTimeToHTTPDate now
+responseMessage withBody contentType msg now
+  | withBody && TL.length msg > maxResponseChars =
+      responseError True errorPayloadTooLarge
+  | otherwise =
+      mconcat $ intersperse nl
+        [ "HTTP/1.1 200 OK"
+        , hdrContentLength contentLength
+        , contentType
+        , "Date: " <> byteString httpDate
+        , ""
+        , if withBody then lazyByteString contentLBS else ""
+        ]
+  where
+    contentLBS    = T.encodeUtf8 msg
+    contentLength = if withBody then BCL.length contentLBS else 0
+    httpDate      = formatHTTPDate $ epochTimeToHTTPDate now