Merge pull request #44 from IntersectMBO/coot/fmaste-cardano-logging

trace-dispatcher integration

Author: coot

cabal.project

@@ -18,7 +18,7 @@ index-state:
   , hackage.haskell.org 2026-02-17T10:15:41Z
 
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2026-03-17T12:33:13Z
+  , cardano-haskell-packages 2026-03-25T05:20:03Z
 
 packages:
   ./dmq-node

dmq-node/app/Main.hs

@@ -1,23 +1,24 @@
 {-# LANGUAGE DataKinds                #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE MultiWayIf               #-}
+{-# LANGUAGE NamedFieldPuns           #-}
 {-# LANGUAGE OverloadedRecordDot      #-}
 {-# LANGUAGE OverloadedStrings        #-}
+{-# LANGUAGE PackageImports           #-}
 {-# LANGUAGE ScopedTypeVariables      #-}
 {-# LANGUAGE TemplateHaskell          #-}
 {-# LANGUAGE TypeApplications         #-}
 {-# LANGUAGE TypeOperators            #-}
 
 module Main where
 
-import Control.Concurrent.Class.MonadMVar
 import Control.Concurrent.Class.MonadSTM.Strict
 import Control.Monad (unless, void, when)
+import Control.Monad.Class.MonadAsync
 import Control.Monad.Class.MonadThrow
-import Control.Tracer (Tracer (..), nullTracer, traceWith)
+import "contra-tracer" Control.Tracer (nullTracer, traceWith)
 
 import Data.Act
-import Data.Aeson (ToJSON)
 import Data.ByteString.Lazy qualified as BSL
 import Data.Foldable (traverse_)
 import Data.Functor.Contravariant ((>$<))
@@ -31,28 +32,29 @@ import Options.Applicative
 import System.Directory qualified as Dir
 import System.Exit (die, exitSuccess)
 import System.IOManager (withIOManager)
+import System.Metrics qualified as EKG
 import System.Random qualified as Random
 
 import Cardano.Git.Rev (gitRev)
 import Cardano.KESAgent.Protocols.StandardCrypto (StandardCrypto)
+import Cardano.Logging.Prometheus.TCPServer qualified as Prometheus
 
 import DMQ.Configuration
 import DMQ.Configuration.CLIOptions (parseCLIOptions)
 import DMQ.Configuration.Topology (readTopologyFileOrError)
 import DMQ.Diffusion.Applications (diffusionApplications)
 import DMQ.Diffusion.Arguments
 import DMQ.Diffusion.NodeKernel
+import DMQ.Diffusion.PeerSelection (policy)
 import DMQ.Handlers.TopLevel (toplevelExceptionHandler)
 import DMQ.NodeToClient qualified as NtC
+import DMQ.NodeToClient.LocalStateQueryClient
 import DMQ.NodeToNode (NodeToNodeVersion, dmqCodecs, dmqLimitsAndTimeouts,
            ntnApps)
 import DMQ.Policy qualified as Policy
 import DMQ.Protocol.SigSubmission.Type (Sig (..))
-import DMQ.Tracer
-
-import DMQ.Diffusion.PeerSelection (policy)
-import DMQ.NodeToClient.LocalStateQueryClient
 import DMQ.Protocol.SigSubmission.Validate
+import DMQ.Tracer (DMQStartupTrace (..), DMQTracers (..), mkDMQTracers)
 import Ouroboros.Network.Diffusion qualified as Diffusion
 import Ouroboros.Network.PeerSelection.LedgerPeers.Type
 import Ouroboros.Network.PeerSelection.PeerSharing.Codec (decodeRemoteAddress,
@@ -78,30 +80,43 @@ runDMQ commandLineConfig = do
                        $ dmqcConfigFile commandLineConfig
                    `act` dmqcConfigFile defaultConfiguration
 
+    ekgStore <- EKG.newStore
+    EKG.registerGcMetrics ekgStore
+
     -- read & parse configuration file
     config' <- readConfigurationFileOrError configFilePath
     -- combine default configuration, configuration file and command line
     -- options
-    let dmqConfig@Configuration {
-          dmqcPrettyLog             = I prettyLog,
+    let dmqConfig :: Configuration
+        dmqConfig@Configuration {
           dmqcTopologyFile          = I topologyFile,
-          dmqcHandshakeTracer       = I handshakeTracer,
-          dmqcValidationTracer      = I validationTracer,
-          dmqcLocalHandshakeTracer  = I localHandshakeTracer,
           dmqcCardanoNodeSocket     = I socketPath,
           dmqcVersion               = I version,
-          dmqcLocalStateQueryTracer = I localStateQueryTracer,
           dmqcLedgerPeers           = I ledgerPeers
         } = config' <> commandLineConfig
             `act`
             defaultConfiguration
 
-    lock <- newMVar ()
-    let tracer', tracer  :: ToJSON ev => Tracer IO (WithEventType ev)
-        tracer' = dmqTracer prettyLog
-        -- use a lock to prevent writing two lines at the same time
-        -- TODO: this won't be needed with `cardano-tracer` integration
-        tracer = Tracer $ \a -> withMVar lock $ \_ -> traceWith tracer' a
+    (   dmqTracers@DMQTracers {
+          dmqStartupTracer,
+          localStateQueryClientTracer,
+          sigValidationTracer,
+          localSigValidationTracer,
+          cardanoNodeHandshakeTracer
+        }
+      , dmqDiffusionTracers
+      , prometheusConfig
+      )
+      <- mkDMQTracers ekgStore configFilePath
+
+    case prometheusConfig of
+      Nothing -> return ()
+      Just ps ->
+        -- morally it belongs to `NodeKernel`, but it runs in `IO`, not `m`.
+        Prometheus.runPrometheusSimple
+          (DMQPrometheus >$< dmqStartupTracer)
+          ekgStore ps
+          >>= link
 
     when version $ do
       let gitrev = $(gitRev)
@@ -120,12 +135,11 @@ runDMQ commandLineConfig = do
           ]
       exitSuccess
 
-    traceWith tracer (WithEventType "Configuration" dmqConfig)
+    traceWith dmqStartupTracer (DMQConfiguration dmqConfig)
     Dir.doesFileExist socketPath >>= \a ->
       unless a (die $ "CardanoNodeSocket " ++ show socketPath ++": file does not exist")
     nt <- readTopologyFileOrError topologyFile
-    traceWith tracer (WithEventType "NetworkTopology" nt)
-
+    traceWith dmqStartupTracer (DMQTopology nt)
 
     stdGen <- Random.newStdGen
     let (psRng, policyRng) = Random.splitGen stdGen
@@ -135,15 +149,13 @@ runDMQ commandLineConfig = do
     withIOManager \iocp -> do
       let localSnocket'      = localSnocket iocp
           mkStakePoolMonitor = connectToCardanoNode
-                                 (if localStateQueryTracer
-                                    then WithEventType "LocalStateQuery" >$< tracer
-                                    else nullTracer)
+                                 localStateQueryClientTracer
                                  ledgerPeers
                                  localSnocket'
                                  socketPath
 
       withNodeKernel @StandardCrypto
-                     tracer
+                     dmqTracers
                      dmqConfig
                      psRng
                      mkStakePoolMonitor $ \nodeKernel -> do
@@ -153,9 +165,6 @@ runDMQ commandLineConfig = do
         let sigSize :: Sig StandardCrypto -> SizeInBytes
             sigSize = fromIntegral . BSL.length . sigRawBytes
             mempoolReader = Mempool.getReader sigId sigSize (mempool nodeKernel)
-            ntnValidationTracer = if validationTracer
-                                    then WithEventType "NtN Validation" >$< tracer
-                                    else nullTracer
             dmqNtNApps =
               let ntnMempoolWriter =
                     Mempool.getWriter SigDuplicate
@@ -164,7 +173,7 @@ runDMQ commandLineConfig = do
                                         withPoolValidationCtx (stakePools nodeKernel) (validateSig now sigs)
                                       )
                                       (traverse_ $ \(sigid, reason) -> do
-                                        traceWith ntnValidationTracer $ InvalidSignature sigid reason
+                                        traceWith sigValidationTracer $ InvalidSignature sigid reason
                                         case reason of
                                           SigDuplicate      -> return ()
                                           SigExpired        -> return ()
@@ -174,7 +183,7 @@ runDMQ commandLineConfig = do
                                           err               -> throwIO (SigValidationException sigid err)
                                       )
                                       (mempool nodeKernel)
-               in ntnApps tracer
+               in ntnApps dmqTracers
                           dmqConfig
                           mempoolReader
                           ntnMempoolWriter
@@ -185,9 +194,6 @@ runDMQ commandLineConfig = do
                              (decodeRemoteAddress (maxBound @NodeToNodeVersion)))
                           dmqLimitsAndTimeouts
                           Policy.sigDecisionPolicy
-            ntcValidationTracer = if validationTracer
-                                    then WithEventType "NtC Validation" >$< tracer
-                                    else nullTracer
             dmqNtCApps =
               let ntcMempoolWriter =
                     Mempool.getWriter SigDuplicate
@@ -196,19 +202,15 @@ runDMQ commandLineConfig = do
                                         withPoolValidationCtx (stakePools nodeKernel) (validateSig now sigs)
                                       )
                                       (traverse_ $ \(sigid, reason) ->
-                                         traceWith ntcValidationTracer $ InvalidSignature sigid reason
+                                         traceWith localSigValidationTracer $ InvalidSignature sigid reason
                                       )
                                       (mempool nodeKernel)
-               in NtC.ntcApps tracer dmqConfig
+               in NtC.ntcApps dmqTracers dmqConfig
                               mempoolReader ntcMempoolWriter
                               NtC.dmqCodecs
             dmqDiffusionArguments =
-              diffusionArguments (if handshakeTracer
-                                    then WithEventType "Handshake" >$< tracer
-                                    else nullTracer)
-                                 (if localHandshakeTracer
-                                    then WithEventType "Handshake" >$< tracer
-                                    else nullTracer)
+              diffusionArguments nullTracer
+                                 cardanoNodeHandshakeTracer
                                  $ maybe [] out <$> tryReadTMVar nodeKernel.stakePools.ledgerPeersVar
               where
                 out :: LedgerPeerSnapshot AllLedgerPeers
@@ -225,6 +227,6 @@ runDMQ commandLineConfig = do
                                     (policy policyRngVar)
 
         Diffusion.run dmqDiffusionArguments
-                      (dmqDiffusionTracers dmqConfig tracer)
+                      dmqDiffusionTracers
                       dmqDiffusionConfiguration
                       dmqDiffusionApplications

dmq-node/changelog.d/20260326_135702_coot_fmaste_cardano_logging.md

@@ -0,0 +1,12 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+### Breaking
+
+- Integration with `trace-dispatcher`.  Removed tracing configuration options
+  from `Configuration`, `trace-dispatcher` configuration is used instead.
+- Added EKG counters and a prometheus server.

dmq-node/changelog.d/20260327_144222_coot_fmaste_cardano_logging.md

@@ -0,0 +1,4 @@
+### Non-Breaking
+
+- Replaced `NoExtraPeers`, `NoExtraState`, `NoExtraDebugState`, `NoExtraFlags` with types from `ouroboros-network`.
+- Removed unused types `NoExtraTracer`, `NoExtraCounters`.

dmq-node/changelog.d/scriv.ini

@@ -3,7 +3,7 @@ format = md
 insert_marker = Changelog entries
 md_header_level = 2
 version = literal: dmq-node.cabal: version
-categories = Breaking, Non-Breaking
+categories = Breaking, Non-Breaking, Patch
 start_marker = scriv-insert-here
 end_marker = scriv-end-here
 fragment_directory = changelog.d

dmq-node/config.json

@@ -1,2 +1,46 @@
 { "NetworkMagic": 12
+, "TraceOptions": {
+    "": {
+      "backends": [
+        "Stdout MachineFormat"
+      ],
+      "severity": "Info"
+    }
+  , "Handshake": {
+      "severity": "Debug"
+    }
+  , "LocalMux": {
+      "severity": "Debug"
+    }
+  , "LocalHandshake": {
+      "severity": "Debug"
+    }
+  , "Diffusion": {
+      "severity": "Debug"
+    }
+  , "PeerSelection": {
+      "severity": "Debug"
+    }
+  , "PeerSelectionCounters": {
+      "severity": "Debug"
+    }
+  , "ConnectionManager": {
+      "severity": "Debug"
+    }
+  , "Server": {
+      "severity": "Debug"
+    }
+  , "InboundGovernor": {
+      "severity": "Debug"
+    }
+  , "LocalMsgSubmission.Protocol.Server": {
+      "severity": "Debug"
+    }
+  , "LocalMsgNotification.Protocol.Server": {
+      "severity": "Debug"
+    }
+  , "SigSubmission.Inbound": {
+      "severity": "Debug"
+    }
+  }
 }

dmq-node/dmq-node.cabal

@@ -63,12 +63,14 @@ library
     DMQ.Diffusion.Applications
     DMQ.Diffusion.Arguments
     DMQ.Diffusion.NodeKernel
+    DMQ.Diffusion.NodeKernel.Types
     DMQ.Diffusion.PeerSelection
     DMQ.Handlers.TopLevel
     DMQ.NodeToClient
     DMQ.NodeToClient.LocalMsgNotification
     DMQ.NodeToClient.LocalMsgSubmission
     DMQ.NodeToClient.LocalStateQueryClient
+    DMQ.NodeToClient.LocalStateQueryClient.Types
     DMQ.NodeToClient.Version
     DMQ.NodeToNode
     DMQ.NodeToNode.Version
@@ -97,7 +99,6 @@ library
     acts,
     acts-generic,
     aeson >=2.1.1.0 && <3,
-    aeson-pretty,
     base >=4.14 && <4.23,
     base16-bytestring,
     bytestring >=0.10 && <0.13,
@@ -116,6 +117,7 @@ library
     contra-tracer >=0.1 && <0.3,
     deepseq >=1.0 && <1.6,
     dns >=1.0 && <4.3,
+    ekg-core,
     generic-data,
     hashable >=1.0 && <1.6,
     io-classes:{io-classes, si-timers, strict-mvar, strict-stm} ^>=1.8.0.1,
@@ -127,12 +129,13 @@ library
     nothunks,
     optparse-applicative >=0.18 && <0.20,
     ouroboros-consensus:{ouroboros-consensus, cardano, diffusion},
-    ouroboros-network:{ouroboros-network, api, framework, orphan-instances, protocols} ^>=1.1.0.0,
+    ouroboros-network:{ouroboros-network, api, framework, framework-tracing, orphan-instances, protocols, tracing} ^>=1.1.0.0,
     quiet,
     random ^>=1.3,
     singletons,
     text >=1.2.4 && <2.2,
     time >=1.12 && <1.15,
+    trace-dispatcher ^>=2.12.0,
     transformers,
     typed-protocols:{typed-protocols, cborg} ^>=1.2,
 
@@ -154,19 +157,20 @@ executable dmq-node
   build-depends:
     Win32-network,
     acts,
-    aeson,
     base,
     bytestring,
     cardano-git-rev,
     contra-tracer >=0.1 && <0.3,
     directory,
     dmq-node,
+    ekg-core,
     io-classes:{io-classes, strict-stm},
     kes-agent-crypto,
     optparse-applicative,
     ouroboros-network:{ouroboros-network, api, framework},
     random,
     text,
+    trace-dispatcher,
 
   hs-source-dirs: app
   default-language: Haskell2010