diff --git a/cabal.project b/cabal.project index d89ffe3319..8e60e4e640 100644 --- a/cabal.project +++ b/cabal.project @@ -20,6 +20,14 @@ index-state: -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2025-03-18T17:41:11Z +-- `trace-dispatcher` from repo "cardano-node" branch "fmaste/dmq-node". +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-node.git + subdir: trace-dispatcher + tag: 9d25e72454269ecca5f138ee2abf3cbbfa619428 + --sha256: 1asb9gx7w50p31wv6hnac7hcmvs3h2m5zrm57p1dpmb70h38xz74 + packages: ./cardano-ping ./monoidal-synchronisation ./network-mux diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index edbda5e1d5..fdf6f5027d 100644 --- a/dmq-node/app/Main.hs +++ b/dmq-node/app/Main.hs @@ -3,14 +3,14 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PackageImports #-} module Main where import Control.Monad (void, when) -import Control.Tracer (Tracer (..), nullTracer, traceWith) +import "contra-tracer" Control.Tracer (Tracer (..), traceWith) import Data.Act -import Data.Aeson (ToJSON) import Data.Functor.Contravariant ((>$<)) import Data.Maybe (maybeToList) import Data.Text qualified as Text @@ -46,6 +46,8 @@ import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool import Paths_dmq_node qualified as Meta +import qualified Cardano.Logging as Logging + main :: IO () main = toplevelExceptionHandler $ void . runDMQ =<< execParser opts where @@ -66,16 +68,25 @@ runDMQ commandLineConfig = do -- combine default configuration, configuration file and command line -- options let dmqConfig@Configuration { - dmqcPrettyLog = I prettyLog, dmqcTopologyFile = I topologyFile, - dmqcHandshakeTracer = I handshakeTracer, - dmqcLocalHandshakeTracer = I localHandshakeTracer, dmqcVersion = I version } = config' <> commandLineConfig `act` defaultConfiguration - let tracer :: ToJSON ev => Tracer IO (WithEventType ev) - tracer = dmqTracer prettyLog + {-- Alternative A + -- Also available "readConfigurationWithDefault"! + --} + traceConfig <- Logging.readConfiguration configFilePath + + {-- + (dmqTracer' :: forall ev. ToJSON ev => Logging.Trace IO (WithEventType ev)) + <- mkCardanoTracer traceConfig + dmqTracer' :: forall ev. ToJSON ev => Logging.Trace IO (WithEventType ev) + --} + dmqTracer' <- mkCardanoTracer traceConfig + + let tracer :: Tracer IO WithEventType + tracer = dmqTracer dmqTracer' when version $ do let gitrev = $(gitRev) @@ -95,9 +106,10 @@ runDMQ commandLineConfig = do ] exitSuccess - traceWith tracer (WithEventType "Configuration" dmqConfig) + traceWith tracer (WithEventType (DMQ "Configuration") dmqConfig) + nt <- readTopologyFileOrError topologyFile - traceWith tracer (WithEventType "NetworkTopology" nt) + traceWith tracer (WithEventType (DMQ "NetworkTopology") nt) stdGen <- newStdGen let (psRng, policyRng) = split stdGen @@ -128,12 +140,8 @@ runDMQ commandLineConfig = do mempoolReader mempoolWriter maxMsgs (NtC.dmqCodecs encodeReject decodeReject) dmqDiffusionArguments = - diffusionArguments (if handshakeTracer - then WithEventType "Handshake" >$< tracer - else nullTracer) - (if localHandshakeTracer - then WithEventType "Handshake" >$< tracer - else nullTracer) + diffusionArguments (WithEventType (DMQ "Handshake") >$< tracer) + (WithEventType (DMQ "LocalHandshake") >$< tracer) dmqDiffusionApplications = diffusionApplications nodeKernel dmqConfig diff --git a/dmq-node/config.json b/dmq-node/config.json index dc0d24b955..cb2cea2af8 100644 --- a/dmq-node/config.json +++ b/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" + } + } } diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index 42cf76e6d8..5c59f7fbbe 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -108,6 +108,7 @@ library singletons, text >=1.2.4 && <2.2, time ^>=1.12, + trace-dispatcher ^>= 2.10.0, typed-protocols:{typed-protocols, cborg} ^>=1.1, hs-source-dirs: src @@ -127,7 +128,6 @@ executable dmq-node build-depends: acts, - aeson, base, cardano-git-rev, contra-tracer >=0.1 && <0.3, @@ -137,6 +137,7 @@ executable dmq-node ouroboros-network:{ouroboros-network, api}, random, text, + trace-dispatcher ^>= 2.10.0 hs-source-dirs: app default-language: Haskell2010 @@ -175,6 +176,7 @@ test-suite dmq-tests serialise, tasty, tasty-quickcheck, + trace-dispatcher ^>= 2.10.0, typed-protocols:{typed-protocols, codec-properties}, with-utf8, diff --git a/dmq-node/src/DMQ/Configuration.hs b/dmq-node/src/DMQ/Configuration.hs index d3b9c8c69a..e77ba86245 100644 --- a/dmq-node/src/DMQ/Configuration.hs +++ b/dmq-node/src/DMQ/Configuration.hs @@ -103,51 +103,6 @@ data Configuration' f = dmqcChurnInterval :: f DiffTime, dmqcPeerSharing :: f PeerSharing, dmqcNetworkMagic :: f NetworkMagic, - dmqcPrettyLog :: f Bool, - - dmqcMuxTracer :: f Bool, - dmqcChannelTracer :: f Bool, - dmqcBearerTracer :: f Bool, - dmqcHandshakeTracer :: f Bool, - dmqcLocalMuxTracer :: f Bool, - dmqcLocalChannelTracer :: f Bool, - dmqcLocalBearerTracer :: f Bool, - dmqcLocalHandshakeTracer :: f Bool, - dmqcDiffusionTracer :: f Bool, - dmqcTraceLocalRootPeersTracer :: f Bool, - dmqcTracePublicRootPeersTracer :: f Bool, - dmqcTraceLedgerPeersTracer :: f Bool, - dmqcTracePeerSelectionTracer :: f Bool, - dmqcTraceChurnCounters :: f Bool, - dmqcDebugPeerSelectionInitiatorTracer :: f Bool, - dmqcDebugPeerSelectionInitiatorResponderTracer :: f Bool, - dmqcTracePeerSelectionCounters :: f Bool, - dmqcPeerSelectionActionsTracer :: f Bool, - dmqcConnectionManagerTracer :: f Bool, - dmqcConnectionManagerTransitionTracer :: f Bool, - dmqcServerTracer :: f Bool, - dmqcInboundGovernorTracer :: f Bool, - dmqcInboundGovernorTransitionTracer :: f Bool, - dmqcLocalConnectionManagerTracer :: f Bool, - dmqcLocalServerTracer :: f Bool, - dmqcLocalInboundGovernorTracer :: f Bool, - dmqcDnsTracer :: f Bool, - - -- low level verbose traces which trace protocol messages - -- TODO: pref - dmqcSigSubmissionClientProtocolTracer :: f Bool, - dmqcSigSubmissionServerProtocolTracer :: f Bool, - dmqcKeepAliveClientProtocolTracer :: f Bool, - dmqcKeepAliveServerProtocolTracer :: f Bool, - dmqcPeerSharingClientProtocolTracer :: f Bool, - dmqcPeerSharingServerProtocolTracer :: f Bool, - dmqcLocalMsgSubmissionServerProtocolTracer :: f Bool, - dmqcLocalMsgNotificationServerProtocolTracer :: f Bool, - - dmqcSigSubmissionLogicTracer :: f Bool, - dmqcSigSubmissionOutboundTracer :: f Bool, - dmqcSigSubmissionInboundTracer :: f Bool, - dmqcLocalMsgSubmissionServerTracer :: f Bool, dmqcVersion :: f Bool } @@ -222,48 +177,6 @@ defaultConfiguration = Configuration { dmqcProtocolIdleTimeout = I defaultProtocolIdleTimeout, dmqcChurnInterval = I defaultDeadlineChurnInterval, dmqcPeerSharing = I PeerSharingEnabled, - dmqcPrettyLog = I False, - dmqcMuxTracer = I False, - dmqcChannelTracer = I False, - dmqcBearerTracer = I False, - dmqcHandshakeTracer = I True, - dmqcLocalMuxTracer = I True, - dmqcLocalChannelTracer = I False, - dmqcLocalBearerTracer = I False, - dmqcLocalHandshakeTracer = I True, - dmqcDiffusionTracer = I True, - dmqcTraceLocalRootPeersTracer = I False, - dmqcTracePublicRootPeersTracer = I False, - dmqcTraceLedgerPeersTracer = I False, - dmqcTracePeerSelectionTracer = I True, - dmqcTraceChurnCounters = I False, - dmqcDebugPeerSelectionInitiatorTracer = I False, - dmqcDebugPeerSelectionInitiatorResponderTracer = I False, - dmqcTracePeerSelectionCounters = I True, - dmqcPeerSelectionActionsTracer = I False, - dmqcConnectionManagerTracer = I True, - dmqcConnectionManagerTransitionTracer = I False, - dmqcServerTracer = I True, - dmqcInboundGovernorTracer = I True, - dmqcInboundGovernorTransitionTracer = I False, - dmqcLocalConnectionManagerTracer = I False, - dmqcLocalServerTracer = I False, - dmqcLocalInboundGovernorTracer = I False, - dmqcDnsTracer = I False, - - dmqcSigSubmissionClientProtocolTracer = I False, - dmqcSigSubmissionServerProtocolTracer = I False, - dmqcKeepAliveClientProtocolTracer = I False, - dmqcKeepAliveServerProtocolTracer = I False, - dmqcPeerSharingClientProtocolTracer = I False, - dmqcPeerSharingServerProtocolTracer = I False, - dmqcLocalMsgSubmissionServerProtocolTracer = I True, - dmqcLocalMsgNotificationServerProtocolTracer = I True, - - dmqcSigSubmissionOutboundTracer = I False, - dmqcSigSubmissionInboundTracer = I True, - dmqcSigSubmissionLogicTracer = I False, - dmqcLocalMsgSubmissionServerTracer = I True, -- CLI only options dmqcVersion = I False @@ -312,50 +225,6 @@ instance FromJSON PartialConfig where dmqcProtocolIdleTimeout <- Last <$> v .:? "ProtocolIdleTimeout" dmqcChurnInterval <- Last <$> v .:? "ChurnInterval" - dmqcPrettyLog <- Last <$> v .:? "PrettyLog" - - dmqcMuxTracer <- Last <$> v .:? "MuxTracer" - dmqcChannelTracer <- Last <$> v .:? "ChannelTracer" - dmqcBearerTracer <- Last <$> v .:? "BearerTracer" - dmqcHandshakeTracer <- Last <$> v .:? "HandshakeTracer" - dmqcLocalMuxTracer <- Last <$> v .:? "LocalMuxTracer" - dmqcLocalChannelTracer <- Last <$> v .:? "LocalChannelTracer" - dmqcLocalBearerTracer <- Last <$> v .:? "LocalBearerTracer" - dmqcLocalHandshakeTracer <- Last <$> v .:? "LocalHandshakeTracer" - dmqcDiffusionTracer <- Last <$> v .:? "DiffusionTracer" - dmqcTraceLocalRootPeersTracer <- Last <$> v .:? "LocalRootPeersTracer" - dmqcTracePublicRootPeersTracer <- Last <$> v .:? "PublicRootPeersTracer" - dmqcTraceLedgerPeersTracer <- Last <$> v .:? "LedgerPeersTracer" - dmqcTracePeerSelectionTracer <- Last <$> v .:? "PeerSelectionTracer" - dmqcTraceChurnCounters <- Last <$> v .:? "ChurnCounters" - dmqcDebugPeerSelectionInitiatorTracer <- Last <$> v .:? "DebugPeerSelectionInitiatorTracer" - dmqcDebugPeerSelectionInitiatorResponderTracer <- Last <$> v .:? "DebugPeerSelectionInitiatorResponderTracer" - dmqcTracePeerSelectionCounters <- Last <$> v .:? "PeerSelectionCounters" - dmqcPeerSelectionActionsTracer <- Last <$> v .:? "PeerSelectionActionsTracer" - dmqcConnectionManagerTracer <- Last <$> v .:? "ConnectionManagerTracer" - dmqcConnectionManagerTransitionTracer <- Last <$> v .:? "ConnectionManagerTransitionTracer" - dmqcServerTracer <- Last <$> v .:? "ServerTracer" - dmqcInboundGovernorTracer <- Last <$> v .:? "InboundGovernorTracer" - dmqcInboundGovernorTransitionTracer <- Last <$> v .:? "InboundGovernorTransitionTracer" - dmqcLocalConnectionManagerTracer <- Last <$> v .:? "LocalConnectionManagerTracer" - dmqcLocalServerTracer <- Last <$> v .:? "LocalServerTracer" - dmqcLocalInboundGovernorTracer <- Last <$> v .:? "LocalInboundGovernorTracer" - dmqcDnsTracer <- Last <$> v .:? "DnsTracer" - - dmqcSigSubmissionClientProtocolTracer <- Last <$> v .:? "SigSubmissionClientProtocolTracer" - dmqcSigSubmissionServerProtocolTracer <- Last <$> v .:? "SigSubmissionServerProtocolTracer" - dmqcKeepAliveClientProtocolTracer <- Last <$> v .:? "KeepAliveServerProtocolTracer" - dmqcKeepAliveServerProtocolTracer <- Last <$> v .:? "KeepAliveClientProtocolTracer" - dmqcPeerSharingClientProtocolTracer <- Last <$> v .:? "PeerSharingServerProtocolTracer" - dmqcPeerSharingServerProtocolTracer <- Last <$> v .:? "PeerSharingClientProtocolTracer" - dmqcLocalMsgSubmissionServerProtocolTracer <- Last <$> v .:? "LocalMsgSubmissionServerProtocolracer" - dmqcLocalMsgNotificationServerProtocolTracer <- Last <$> v .:? "LocalMsgNotificationServerProtocolracer" - - dmqcSigSubmissionOutboundTracer <- Last <$> v .:? "SigSubmissionOutboundTracer" - dmqcSigSubmissionInboundTracer <- Last <$> v .:? "SigSubmissionInboundTracer" - dmqcSigSubmissionLogicTracer <- Last <$> v .:? "SigSubmissionLogicTracer" - dmqcLocalMsgSubmissionServerTracer <- Last <$> v .:? "LocalMsgSubmissionServerTracer" - pure $ Configuration { dmqcIPv4 = Last dmqcIPv4 @@ -389,45 +258,6 @@ instance ToJSON Configuration where , "ChurnInterval" .= unI dmqcChurnInterval , "PeerSharing" .= unI dmqcPeerSharing , "NetworkMagic" .= unNetworkMagic (unI dmqcNetworkMagic) - , "PrettyLog" .= unI dmqcPrettyLog - , "MuxTracer" .= unI dmqcMuxTracer - , "ChannelTracer" .= unI dmqcChannelTracer - , "BearerTracer" .= unI dmqcBearerTracer - , "HandshakeTracer" .= unI dmqcHandshakeTracer - , "LocalMuxTracer" .= unI dmqcLocalMuxTracer - , "LocalChannelTracer" .= unI dmqcLocalChannelTracer - , "LocalBearerTracer" .= unI dmqcLocalBearerTracer - , "LocalHandshakeTracer" .= unI dmqcLocalHandshakeTracer - , "DiffusionTracer" .= unI dmqcDiffusionTracer - , "LocalRootPeersTracer" .= unI dmqcTraceLocalRootPeersTracer - , "PublicRootPeersTracer" .= unI dmqcTracePublicRootPeersTracer - , "LedgerPeersTracer" .= unI dmqcTraceLedgerPeersTracer - , "PeerSelectionTracer" .= unI dmqcTracePeerSelectionTracer - , "ChurnCounters" .= unI dmqcTraceChurnCounters - , "DebugPeerSelectionInitiatorTracer" .= unI dmqcDebugPeerSelectionInitiatorTracer - , "DebugPeerSelectionInitiatorResponderTracer" .= unI dmqcDebugPeerSelectionInitiatorResponderTracer - , "PeerSelectionCounters" .= unI dmqcTracePeerSelectionCounters - , "PeerSelectionActionsTracer" .= unI dmqcPeerSelectionActionsTracer - , "ConnectionManagerTracer" .= unI dmqcConnectionManagerTracer - , "ConnectionManagerTransitionTracer" .= unI dmqcConnectionManagerTransitionTracer - , "ServerTracer" .= unI dmqcServerTracer - , "InboundGovernorTracer" .= unI dmqcInboundGovernorTracer - , "InboundGovernorTransitionTracer" .= unI dmqcInboundGovernorTransitionTracer - , "LocalConnectionManagerTracer" .= unI dmqcLocalConnectionManagerTracer - , "LocalServerTracer" .= unI dmqcLocalServerTracer - , "LocalInboundGovernorTracer" .= unI dmqcLocalInboundGovernorTracer - , "DnsTracer" .= unI dmqcDnsTracer - , "SigSubmissionClientProtocolTracer" .= unI dmqcSigSubmissionClientProtocolTracer - , "SigSubmissionServerProtocolTracer" .= unI dmqcSigSubmissionServerProtocolTracer - , "KeepAliveClientProtocolTracer" .= unI dmqcKeepAliveClientProtocolTracer - , "KeepAliveServerProtocolTracer" .= unI dmqcKeepAliveServerProtocolTracer - , "PeerSharingClientProtocolTracer" .= unI dmqcPeerSharingClientProtocolTracer - , "PeerSharingServerProtocolTracer" .= unI dmqcPeerSharingServerProtocolTracer - , "LocalMsgSubmissionServerProtocolTracer" .= unI dmqcLocalMsgSubmissionServerProtocolTracer - , "LocalMsgNotificationServerProtocolTracer" .= unI dmqcLocalMsgNotificationServerProtocolTracer - , "SigSubmissionOutboundTracer" .= unI dmqcSigSubmissionOutboundTracer - , "SigSubmissionInboundTracer" .= unI dmqcSigSubmissionInboundTracer - , "SigSubmissionLogicTracer" .= unI dmqcSigSubmissionLogicTracer ] -- | Read the `DMQConfiguration` from the specified file. @@ -462,7 +292,7 @@ readConfigurationFileOrError -> IO PartialConfig readConfigurationFileOrError nc = readConfigurationFile nc - >>= either (\err -> error $ "DMQ.Topology.eeadConfigurationFile: " + >>= either (\err -> error $ "DMQ.Topology.readConfigurationFile: " <> Text.unpack err) pure diff --git a/dmq-node/src/DMQ/Diffusion/Arguments.hs b/dmq-node/src/DMQ/Diffusion/Arguments.hs index 20c882c45b..ad09518ae6 100644 --- a/dmq-node/src/DMQ/Diffusion/Arguments.hs +++ b/dmq-node/src/DMQ/Diffusion/Arguments.hs @@ -2,6 +2,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} module DMQ.Diffusion.Arguments ( diffusionArguments @@ -21,7 +22,7 @@ import Control.Exception (IOException) import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadCatch) import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer) -import Control.Tracer (Tracer) +import "contra-tracer" Control.Tracer (Tracer) import Network.DNS (Resolver) import Network.Socket (Socket) diff --git a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs index da282e989a..c3a3d7771b 100644 --- a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs +++ b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} module DMQ.Diffusion.NodeKernel ( NodeKernel (..) @@ -13,9 +14,8 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI -import Control.Tracer (Tracer, nullTracer) +import "contra-tracer" Control.Tracer (Tracer, nullTracer) -import Data.Aeson qualified as Aeson import Data.Function (on) import Data.Functor.Contravariant ((>$<)) import Data.Hashable @@ -108,7 +108,7 @@ withNodeKernel :: forall crypto ntnAddr m a. , Show ntnAddr , Hashable ntnAddr ) - => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) + => Tracer m WithEventType -> Configuration -> StdGen -> (NodeKernel crypto ntnAddr m -> m a) @@ -116,9 +116,7 @@ withNodeKernel :: forall crypto ntnAddr m a. -- decision logic threads will be killed -> m a withNodeKernel tracer - Configuration { - dmqcSigSubmissionLogicTracer = I sigSubmissionLogicTracer - } + _ rng k = do nodeKernel@NodeKernel { mempool, sigChannelVar, @@ -128,9 +126,7 @@ withNodeKernel tracer withAsync (mempoolWorker mempool) $ \mempoolThread -> withAsync (decisionLogicThreads - (if sigSubmissionLogicTracer - then WithEventType "SigSubmission.Logic" >$< tracer - else nullTracer) + (WithEventType (DMQ "SigSubmission.Logic") >$< tracer) nullTracer defaultSigDecisionPolicy sigChannelVar diff --git a/dmq-node/src/DMQ/NodeToClient.hs b/dmq-node/src/DMQ/NodeToClient.hs index a6684db27d..2afd464c6c 100644 --- a/dmq-node/src/DMQ/NodeToClient.hs +++ b/dmq-node/src/DMQ/NodeToClient.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PackageImports #-} module DMQ.NodeToClient ( module DMQ.NodeToClient.Version @@ -24,7 +25,7 @@ import Control.Concurrent.Class.MonadSTM import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow -import Control.Tracer (Tracer, nullTracer) +import "contra-tracer" Control.Tracer (Tracer, nullTracer) import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR @@ -140,7 +141,7 @@ ntcApps , Typeable crypto , Aeson.ToJSON ntcAddr ) - => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) + => (Tracer m WithEventType) -> Configuration -> TxSubmissionMempoolReader SigId (Sig crypto) idx m -> TxSubmissionMempoolWriter SigId (Sig crypto) idx m @@ -148,10 +149,7 @@ ntcApps -> Codecs crypto m -> Apps ntcAddr m () ntcApps tracer - Configuration { dmqcLocalMsgSubmissionServerProtocolTracer = I localMsgSubmissionServerProtocolTracer, - dmqcLocalMsgNotificationServerProtocolTracer = I localMsgNotificationServerProtocolTracer, - dmqcLocalMsgSubmissionServerTracer = I localMsgSubmissionServerTracer - } + _ mempoolReader mempoolWriter maxMsgs @@ -164,27 +162,19 @@ ntcApps tracer aLocalMsgSubmission _version ResponderContext { rcConnectionId = connId } channel = do labelThisThread "LocalMsgSubmission.Server" runAnnotatedPeer - (if localMsgSubmissionServerProtocolTracer - then WithEventType "LocalMsgSubmission.Protocol.Server" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "LocalMsgSubmission.Protocol.Server") . Mx.WithBearer connId >$< tracer) msgSubmissionCodec channel (localMsgSubmissionServerPeer $ localMsgSubmissionServer sigId - -- TODO: use a separate option for this tracer rather than reusing - -- `dmqLocalMsgSubmissionServerTracer`. - (if localMsgSubmissionServerTracer - then WithEventType "LocalMsgSubmission.Server" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "LocalMsgSubmission.Server") . Mx.WithBearer connId >$< tracer) mempoolWriter) aLocalMsgNotification _version ResponderContext { rcConnectionId = connId } channel = do labelThisThread "LocalMsgNotification.Server" runAnnotatedPeer - (if localMsgNotificationServerProtocolTracer - then WithEventType "LocalMsgNotification.Protocol.Server" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "LocalMsgNotification.Protocol.Server") . Mx.WithBearer connId >$< tracer) msgNotificationCodec channel (localMsgNotificationServerPeer $ diff --git a/dmq-node/src/DMQ/NodeToClient/LocalMsgNotification.hs b/dmq-node/src/DMQ/NodeToClient/LocalMsgNotification.hs index fe7ce7d95f..38fa06bb0d 100644 --- a/dmq-node/src/DMQ/NodeToClient/LocalMsgNotification.hs +++ b/dmq-node/src/DMQ/NodeToClient/LocalMsgNotification.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + module DMQ.NodeToClient.LocalMsgNotification ( localMsgNotificationServer , LocalMsgNotificationProtocolError (..) @@ -5,7 +7,7 @@ module DMQ.NodeToClient.LocalMsgNotification import Control.Concurrent.Class.MonadSTM import Control.Monad.Class.MonadThrow -import Control.Tracer +import "contra-tracer" Control.Tracer import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (fromJust) import Data.Traversable (mapAccumR) diff --git a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs index 152ed979c1..5d9beb0c28 100644 --- a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs +++ b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} module DMQ.NodeToClient.LocalMsgSubmission where import Control.Concurrent.Class.MonadSTM -import Control.Tracer +import "contra-tracer" Control.Tracer import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson qualified as Aeson import Data.Maybe diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs index 9ff7a3acc7..f9a15a5472 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} module DMQ.NodeToNode ( RemoteAddress @@ -33,7 +34,7 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer.SI -import Control.Tracer (Tracer, nullTracer) +import "contra-tracer" Control.Tracer (Tracer, nullTracer) import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR @@ -54,7 +55,7 @@ import Network.TypedProtocol.Codec (AnnotatedCodec, Codec) import Cardano.KESAgent.KES.Crypto (Crypto (..)) -import DMQ.Configuration (Configuration, Configuration' (..), I (..)) +import DMQ.Configuration (Configuration) import DMQ.Diffusion.NodeKernel (NodeKernel (..)) import DMQ.NodeToNode.Version import DMQ.Protocol.SigSubmission.Codec @@ -161,7 +162,7 @@ ntnApps , Hashable addr , Aeson.ToJSON addr ) - => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) + => (Tracer m WithEventType) -> Configuration -> NodeKernel crypto addr m -> Codecs crypto addr m @@ -170,18 +171,7 @@ ntnApps -> Apps addr m () () ntnApps tracer - Configuration { - dmqcSigSubmissionClientProtocolTracer = I sigSubmissionClientProtocolTracer - , dmqcSigSubmissionServerProtocolTracer = I sigSubmissionServerProtocolTracer - , dmqcKeepAliveClientProtocolTracer = I keepAliveClientProtocolTracer - , dmqcKeepAliveServerProtocolTracer = I keepAliveServerProtocolTracer - , dmqcPeerSharingClientProtocolTracer = I peerSharingClientProtocolTracer - , dmqcPeerSharingServerProtocolTracer = I peerSharingServerProtocolTracer - - , dmqcSigSubmissionOutboundTracer = I sigSubmissionOutboundTracer - , dmqcSigSubmissionInboundTracer = I sigSubmissionInboundTracer - , dmqcSigSubmissionLogicTracer = I sigSubmissionLogicTracer - } + _ NodeKernel { fetchClientRegistry , peerSharingRegistry @@ -240,18 +230,14 @@ ntnApps eicControlMessage = controlMessage } channel = runAnnotatedPeerWithLimits - (if sigSubmissionClientProtocolTracer - then WithEventType "SigSubmission.Protocol.Client" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "SigSubmission.Protocol.Client") . Mx.WithBearer connId >$< tracer) sigSubmissionCodec sigSubmissionSizeLimits sigSubmissionTimeLimits channel $ txSubmissionClientPeer $ txSubmissionOutbound - (if sigSubmissionOutboundTracer - then WithEventType "SigSubmission.Outbound" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "SigSubmission.Outbound") . Mx.WithBearer connId >$< tracer) _MAX_SIGS_TO_ACK mempoolReader version @@ -265,9 +251,7 @@ ntnApps -> m ((), Maybe BL.ByteString) aSigSubmissionServer _version ResponderContext { rcConnectionId = connId } channel = SigSubmission.withPeer - (if sigSubmissionLogicTracer - then WithEventType "SigSubmission.Logic" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "SigSubmission.Logic") . Mx.WithBearer connId >$< tracer) sigChannelVar sigMempoolSem sigDecisionPolicy @@ -278,18 +262,14 @@ ntnApps (remoteAddress connId) $ \(peerSigAPI :: PeerTxAPI m SigId (Sig crypto)) -> runPipelinedAnnotatedPeerWithLimits - (if sigSubmissionServerProtocolTracer - then WithEventType "SigSubmission.Protocol.Server" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "SigSubmission.Protocol.Server") . Mx.WithBearer connId >$< tracer) sigSubmissionCodec sigSubmissionSizeLimits sigSubmissionTimeLimits channel $ txSubmissionServerPeerPipelined $ txSubmissionInboundV2 - (if sigSubmissionInboundTracer - then WithEventType "SigSubmission.Inbound" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "SigSubmission.Inbound") . Mx.WithBearer connId >$< tracer) _SIG_SUBMISSION_INIT_DELAY mempoolWriter peerSigAPI @@ -309,9 +289,7 @@ ntnApps labelThisThread "KeepAlive.Client" let kacApp dqCtx = runPeerWithLimits - (if keepAliveClientProtocolTracer - then WithEventType "KeepAlive.Protocol.Client" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "KeepAlive.Protocol.Client") . Mx.WithBearer connId >$< tracer) keepAliveCodec keepAliveSizeLimits keepAliveTimeLimits @@ -339,9 +317,7 @@ ntnApps channel = do labelThisThread "KeepAlive.Server" runPeerWithLimits - (if keepAliveServerProtocolTracer - then WithEventType "KeepAlive.Protocol.Server" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "KeepAlive.Protocol.Server") . Mx.WithBearer connId >$< tracer) keepAliveCodec keepAliveSizeLimits keepAliveTimeLimits @@ -365,9 +341,7 @@ ntnApps $ \controller -> do psClient <- peerSharingClient controlMessageSTM controller ((), trailing) <- runPeerWithLimits - (if peerSharingClientProtocolTracer - then WithEventType "PeerSharing.Protocol.Client" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "PeerSharing.Protocol.Client") . Mx.WithBearer connId >$< tracer) peerSharingCodec peerSharingSizeLimits peerSharingTimeLimits @@ -387,9 +361,7 @@ ntnApps channel = do labelThisThread "PeerSharing.Server" runPeerWithLimits - (if peerSharingServerProtocolTracer - then WithEventType "PeerSharing.Protocol.Server" . Mx.WithBearer connId >$< tracer - else nullTracer) + (WithEventType (DMQ "PeerSharing.Protocol.Server") . Mx.WithBearer connId >$< tracer) peerSharingCodec peerSharingSizeLimits peerSharingTimeLimits diff --git a/dmq-node/src/DMQ/Tracer.hs b/dmq-node/src/DMQ/Tracer.hs index 9643f81f71..e3137ee1da 100644 --- a/dmq-node/src/DMQ/Tracer.hs +++ b/dmq-node/src/DMQ/Tracer.hs @@ -4,12 +4,15 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} module DMQ.Tracer - ( dmqTracer + ( mkCardanoTracer + , dmqTracer , dmqDiffusionTracers + , EventType (..) , WithEventType (..) , NoExtraPeers (..) , NoExtraState (..) @@ -23,16 +26,16 @@ module DMQ.Tracer ) where import Codec.CBOR.Term (Term) -import Control.Monad.Class.MonadTime -import Control.Tracer +import "contra-tracer" Control.Tracer import Data.Aeson import Data.Aeson.Encode.Pretty (encodePretty) -import Data.Bool (bool) -import Data.ByteString.Lazy.Char8 qualified as LBS.Char8 +import Data.Aeson.KeyMap (fromList) import Data.Functor.Contravariant ((>$<)) import Data.Set qualified as Set import Data.Text qualified as Text +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Encoding (decodeUtf8) import Ouroboros.Network.Diffusion qualified as Diffusion import Ouroboros.Network.OrphanInstances () @@ -42,38 +45,224 @@ import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.Snocket (RemoteAddress) +import qualified Cardano.Logging as Logging + import DMQ.Configuration import DMQ.NodeToClient.Version import DMQ.NodeToNode.Version -data TraceEvent ev = TraceEvent - { time :: UTCTime - , eventType :: String - , event :: ev - } +data EventType = + Mux + | Channel + | Bearer + | Handshake + | LocalMux + | LocalChannel + | LocalBearer + | LocalHandshake + | Diffusion + | LocalRootPeers + | PublicRootPeers + | LedgerPeers + | PeerSelection + | ChurnCounters + | DebugPeerSelectionInitiator + | DebugPeerSelectionInitiatorResponder + | PeerSelectionCounters + | PeerSelectionActions + | ConnectionManager + | ConnectionManagerTransition + | Server + | InboundGovernor + | InboundGovernorTransition + | LocalConnectionManager + | LocalServer + | LocalInboundGovernor + | Dns + | DMQ String + deriving (Eq, Show) -instance ToJSON ev => ToJSON (TraceEvent ev) where - toJSON TraceEvent {time, eventType, event} = - object [ "time" .= time - , "type" .= eventType - , "event" .= event - ] +data WithEventType = forall a. ToJSON a => WithEventType EventType a + +instance Logging.LogFormatting WithEventType where + -- Machine readable representation with varying details based on the detail level. + -- forMachine :: DetailLevel -> a -> Aeson.Object + forMachine _ (WithEventType _ event) = fromList [ ("data", toJSON event) ] + -- Human readable representation. + -- forHuman :: a -> Text + forHuman (WithEventType _ event) = toStrict $ decodeUtf8 $ encodePretty event + -- Metrics representation. + -- asMetrics :: a -> [Metric] + asMetrics _ = [] -data WithEventType a = WithEventType String a - deriving Show -instance ToJSON a => ToJSON (WithEventType a) where - toJSON (WithEventType eventType a) = toJSON (eventType, a) +instance Logging.MetaTrace WithEventType where + -- allNamespaces :: [Namespace a] + allNamespaces = [ + -- Diffusion traces. + -------------------- + Logging.Namespace [] ["Mux"] + , Logging.Namespace [] ["Channel"] + , Logging.Namespace [] ["Bearer"] + , Logging.Namespace [] ["Handshake"] + , Logging.Namespace [] ["LocalMux"] + , Logging.Namespace [] ["LocalChannel"] + , Logging.Namespace [] ["LocalBearer"] + , Logging.Namespace [] ["LocalHandshake"] + , Logging.Namespace [] ["Diffusion"] + , Logging.Namespace [] ["LocalRootPeers"] + , Logging.Namespace [] ["PublicRootPeers"] + , Logging.Namespace [] ["LedgerPeers"] + , Logging.Namespace [] ["PeerSelection"] + , Logging.Namespace [] ["ChurnCounters"] + , Logging.Namespace [] ["DebugPeerSelectionInitiator"] + , Logging.Namespace [] ["DebugPeerSelectionInitiatorResponder"] + , Logging.Namespace [] ["PeerSelectionCounters"] + , Logging.Namespace [] ["PeerSelectionActions"] + , Logging.Namespace [] ["ConnectionManager"] + , Logging.Namespace [] ["ConnectionManagerTransition"] + , Logging.Namespace [] ["Server"] + , Logging.Namespace [] ["InboundGovernor"] + , Logging.Namespace [] ["InboundGovernorTransition"] + , Logging.Namespace [] ["LocalConnectionManager"] + , Logging.Namespace [] ["LocalServer"] + , Logging.Namespace [] ["LocalInboundGovernor"] + , Logging.Namespace [] ["DnsTracer"] + -- DMQ-Node only traces. + ------------------------ + -- Main. + , Logging.Namespace [] ["Configuration"] + , Logging.Namespace [] ["Handshake"] + , Logging.Namespace [] ["NetworkTopology"] + -- Diffusion.NodeKernel and NodeToClient + , Logging.Namespace [] ["SigSubmission.Logic"] + -- NodeToClient. + , Logging.Namespace [] ["LocalMsgNotification.Protocol.Server"] + , Logging.Namespace [] ["LocalMsgSubmission.Protocol.Server"] + , Logging.Namespace [] ["LocalMsgSubmission.Server"] + -- NodeToNode. + , Logging.Namespace [] ["KeepAlive.Protocol.Client"] + , Logging.Namespace [] ["KeepAlive.Protocol.Server"] + , Logging.Namespace [] ["PeerSharing.Protocol.Client"] + , Logging.Namespace [] ["PeerSharing.Protocol.Server"] + , Logging.Namespace [] ["SigSubmission.Inbound"] + , Logging.Namespace [] ["SigSubmission.Logic"] + , Logging.Namespace [] ["SigSubmission.Outbound"] + , Logging.Namespace [] ["SigSubmission.Protocol.Client"] + , Logging.Namespace [] ["SigSubmission.Protocol.Server"] + ] + namespaceFor (WithEventType et _) = Logging.Namespace [] [(Text.pack $ show et)] + severityFor (Logging.Namespace [] ["Mux"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["Channel"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["Bearer"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["Handshake"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["LocalMux"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["LocalChannel"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["LocalBearer"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["LocalHandshake"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["Diffusion"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["LocalRootPeers"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["PublicRootPeers"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["LedgerPeers"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["PeerSelection"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["ChurnCounters"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["DebugPeerSelectionInitiator"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["DebugPeerSelectionInitiatorResponder"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["PeerSelectionCounters"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["PeerSelectionActions"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["ConnectionManager"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["ConnectionManagerTransition"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["Server"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["InboundGovernor"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["InboundGovernorTransition"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["LocalConnectionManager"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["LocalServerTracer"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["LocalInboundGovernor"]) _ = Just Logging.Info + severityFor (Logging.Namespace [] ["Dns"]) _ = Just Logging.Info + severityFor _ _ = Just Logging.Info + privacyFor _ _ = Just Logging.Public + detailsFor (Logging.Namespace [] ["Mux"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["Channel"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["Bearer"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["Handshake"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["LocalMux"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["LocalChannel"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["LocalBearer"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["LocalHandshake"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["Diffusion"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["LocalRootPeers"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["PublicRootPeers"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["LedgerPeers"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["PeerSelection"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["ChurnCounters"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["DebugPeerSelectionInitiator"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["DebugPeerSelectionInitiatorResponder"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["PeerSelectionCounters"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["PeerSelectionActions"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["ConnectionManager"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["ConnectionManagerTransition"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["Server"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["InboundGovernor"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["InboundGovernorTransition"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["LocalConnectionManager"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["LocalServer"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["LocalInboundGovernor"]) _ = Just Logging.DNormal + detailsFor (Logging.Namespace [] ["Dns"]) _ = Just Logging.DNormal + detailsFor _ _ = Just Logging.DNormal + documentFor _ = Nothing + metricsDocFor _ = [] + +mkCardanoTracer :: Logging.TraceConfig + -> IO (Logging.Trace IO WithEventType) +mkCardanoTracer traceConfig = do + emptyConfigReflection <- Logging.emptyConfigReflection + stdoutTrace <- Logging.standardTracer + {-- From: Cardano.Logging.Tracer.Composed + -- | Construct a tracer according to the requirements for cardano node. + -- The tracer gets a 'name', which is appended to its namespace. + -- The tracer has to be an instance of LogFormatting for the display of + -- messages and an instance of MetaTrace for meta information such as + -- severity, privacy, details and backends'. + -- The tracer gets the backends': 'trStdout', 'trForward' and 'mbTrEkg' + -- as arguments. + -- The returned tracer needs to be configured with a configuration + -- before it is used. + mkCardanoTracer :: forall evt. ( LogFormatting evt , MetaTrace evt) + => Trace IO FormattedMessage + -> Trace IO FormattedMessage + -> Maybe (Trace IO FormattedMessage) + -> [Text] + -> IO (Trace IO evt) + --} + tracer <- Logging.mkCardanoTracer + stdoutTrace + mempty + Nothing + [] -- ["DMQ"] + {-- From: Cardano.Logging.Configuration + -- | 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 one tracer of the same time, it is not a common case to do this. + configureTracers :: forall a m. (MetaTrace a , MonadIO m) + => ConfigReflection + -> TraceConfig + -> [Trace m a] + -> m () + --} + Logging.configureTracers + emptyConfigReflection + traceConfig + [tracer] + return tracer -- | DMQ tracer -dmqTracer :: ToJSON ev - => Bool - -> Tracer IO (WithEventType ev) -dmqTracer pretty = contramapM - (\(WithEventType eventType event) -> do - time <- getCurrentTime - return $ bool encode encodePretty pretty TraceEvent { time, eventType, event } +dmqTracer :: (Logging.Trace IO WithEventType) + -> Tracer IO WithEventType +dmqTracer cardanoTracer = contramapM + (\wet@(WithEventType _ _) -> do + Logging.traceWith cardanoTracer wet ) - $ Tracer LBS.Char8.putStrLn + $ Tracer (\_ -> return ()) -- An orphan instance needed for `Handshake versionNumber Term` instance ToJSON Term where @@ -158,10 +347,8 @@ instance ToJSON (DebugPeerSelection NoExtraState NoExtraFlags NoExtraPeers Remot ] dmqDiffusionTracers - :: forall m. - Applicative m - => Configuration - -> (forall ev. ToJSON ev => Tracer m (WithEventType ev)) + :: Configuration + -> (Tracer m WithEventType) -> Diffusion.Tracers RemoteAddress NodeToNodeVersion NodeToNodeVersionData LocalAddress NodeToClientVersion NodeToClientVersionData NoExtraState @@ -171,95 +358,34 @@ dmqDiffusionTracers NoExtraCounters NoExtraTracer m -dmqDiffusionTracers - Configuration { - dmqcMuxTracer = I muxTracer, - dmqcChannelTracer = I channelTracer, - dmqcBearerTracer = I bearerTracer, - dmqcHandshakeTracer = I handshakeTracer, - dmqcLocalMuxTracer = I localMuxTracer, - dmqcLocalChannelTracer = I localChannelTracer, - dmqcLocalBearerTracer = I localBearerTracer, - dmqcLocalHandshakeTracer = I localHandshakeTracer, - dmqcDiffusionTracer = I diffusionTracer, - dmqcTraceLocalRootPeersTracer = I traceLocalRootPeersTracer, - dmqcTracePublicRootPeersTracer = I tracePublicRootPeersTracer, - dmqcTraceLedgerPeersTracer = I traceLedgerPeersTracer, - dmqcTracePeerSelectionTracer = I tracePeerSelectionTracer, - dmqcTraceChurnCounters = I traceChurnCounters, - dmqcDebugPeerSelectionInitiatorTracer = I debugPeerSelectionInitiatorTracer, - dmqcDebugPeerSelectionInitiatorResponderTracer = I debugPeerSelectionInitiatorResponderTracer, - dmqcTracePeerSelectionCounters = I tracePeerSelectionCounters, - dmqcPeerSelectionActionsTracer = I peerSelectionActionsTracer, - dmqcConnectionManagerTracer = I connectionManagerTracer, - dmqcConnectionManagerTransitionTracer = I connectionManagerTransitionTracer, - dmqcServerTracer = I serverTracer, - dmqcInboundGovernorTracer = I inboundGovernorTracer, - dmqcInboundGovernorTransitionTracer = I inboundGovernorTransitionTracer, - dmqcLocalConnectionManagerTracer = I localConnectionManagerTracer, - dmqcLocalServerTracer = I localServerTracer, - dmqcLocalInboundGovernorTracer = I localInboundGovernorTracer, - dmqcDnsTracer = I dnsTracer - } - tracer - = Diffusion.Tracers { - Diffusion.dtMuxTracer = muxTracer - .- WithEventType "Mux" >$< tracer, - Diffusion.dtChannelTracer = channelTracer - .- WithEventType "Channel" >$< tracer, - Diffusion.dtBearerTracer = bearerTracer - .- WithEventType "Bearer" >$< tracer, - Diffusion.dtHandshakeTracer = handshakeTracer - .- WithEventType "Handshake" >$< tracer, - Diffusion.dtLocalMuxTracer = localMuxTracer - .- WithEventType "LocalMux" >$< tracer, - Diffusion.dtLocalChannelTracer = localChannelTracer - .- WithEventType "LocalChannel" >$< tracer, - Diffusion.dtLocalBearerTracer = localBearerTracer - .- WithEventType "LocalBearer" >$< tracer, - Diffusion.dtLocalHandshakeTracer = localHandshakeTracer - .- WithEventType "LocalHandshake" >$< tracer, - Diffusion.dtDiffusionTracer = diffusionTracer - .- WithEventType "Diffusion" >$< tracer, - Diffusion.dtTraceLocalRootPeersTracer = traceLocalRootPeersTracer - .- WithEventType "LocalRootPeers" >$< tracer, - Diffusion.dtTracePublicRootPeersTracer = tracePublicRootPeersTracer - .- WithEventType "PublicRootPeers" >$< tracer, - Diffusion.dtTraceLedgerPeersTracer = traceLedgerPeersTracer - .- WithEventType "LedgerPeers" >$< tracer, - Diffusion.dtTracePeerSelectionTracer = tracePeerSelectionTracer - .- WithEventType "PeerSelection" >$< tracer, - Diffusion.dtDebugPeerSelectionInitiatorTracer = debugPeerSelectionInitiatorTracer - .- WithEventType "DebugPeerSelectionInitiator" >$< tracer, - Diffusion.dtDebugPeerSelectionInitiatorResponderTracer = debugPeerSelectionInitiatorResponderTracer - .- WithEventType "DebugPeerSelectionInitiatorResponder" >$< tracer, - Diffusion.dtTracePeerSelectionCounters = tracePeerSelectionCounters - .- WithEventType "PeerSelectionCounters" >$< tracer, - Diffusion.dtTraceChurnCounters = traceChurnCounters - .- WithEventType "ChurnCounters" >$< tracer, - Diffusion.dtPeerSelectionActionsTracer = peerSelectionActionsTracer - .- WithEventType "PeerSelectionActions" >$< tracer, - Diffusion.dtConnectionManagerTracer = connectionManagerTracer - .- WithEventType "ConnectionManager" >$< tracer, - Diffusion.dtConnectionManagerTransitionTracer = connectionManagerTransitionTracer - .- WithEventType "ConnectionManagerTransition" >$< tracer, - Diffusion.dtServerTracer = serverTracer - .- WithEventType "Server" >$< tracer, - Diffusion.dtInboundGovernorTracer = inboundGovernorTracer - .- WithEventType "InboundGovernor" >$< tracer, - Diffusion.dtInboundGovernorTransitionTracer = inboundGovernorTransitionTracer - .- WithEventType "InboundGovernorTransition" >$< tracer, - Diffusion.dtDnsTracer = dnsTracer - .- WithEventType "dtDnsTracer" >$< tracer, - Diffusion.dtLocalConnectionManagerTracer = localConnectionManagerTracer - .- WithEventType "dtLocalConnectionManagerTracer" >$< tracer, - Diffusion.dtLocalServerTracer = localServerTracer - .- WithEventType "dtLocalServerTracer" >$< tracer, - Diffusion.dtLocalInboundGovernorTracer = localInboundGovernorTracer - .- WithEventType "dtLocalInboundGovernorTracer" >$< tracer +dmqDiffusionTracers _ tracer = + Diffusion.Tracers { + Diffusion.dtMuxTracer = WithEventType Mux >$< tracer, + Diffusion.dtChannelTracer = WithEventType Channel >$< tracer, + Diffusion.dtBearerTracer = WithEventType Bearer >$< tracer, + Diffusion.dtHandshakeTracer = WithEventType Handshake >$< tracer, + Diffusion.dtLocalMuxTracer = WithEventType LocalMux >$< tracer, + Diffusion.dtLocalChannelTracer = WithEventType LocalChannel >$< tracer, + Diffusion.dtLocalBearerTracer = WithEventType LocalBearer >$< tracer, + Diffusion.dtLocalHandshakeTracer = WithEventType LocalHandshake >$< tracer, + Diffusion.dtDiffusionTracer = WithEventType Diffusion >$< tracer, + Diffusion.dtTraceLocalRootPeersTracer = WithEventType LocalRootPeers >$< tracer, + Diffusion.dtTracePublicRootPeersTracer = WithEventType PublicRootPeers >$< tracer, + Diffusion.dtTraceLedgerPeersTracer = WithEventType LedgerPeers >$< tracer, + Diffusion.dtTracePeerSelectionTracer = WithEventType PeerSelection >$< tracer, + Diffusion.dtTraceChurnCounters = WithEventType ChurnCounters >$< tracer, + Diffusion.dtDebugPeerSelectionInitiatorTracer = WithEventType DebugPeerSelectionInitiator >$< tracer, + Diffusion.dtDebugPeerSelectionInitiatorResponderTracer = WithEventType DebugPeerSelectionInitiatorResponder >$< tracer, + Diffusion.dtTracePeerSelectionCounters = WithEventType PeerSelectionCounters >$< tracer, + Diffusion.dtPeerSelectionActionsTracer = WithEventType PeerSelectionActions >$< tracer, + Diffusion.dtConnectionManagerTracer = WithEventType ConnectionManager >$< tracer, + Diffusion.dtConnectionManagerTransitionTracer = WithEventType ConnectionManagerTransition >$< tracer, + Diffusion.dtServerTracer = WithEventType Server >$< tracer, + Diffusion.dtInboundGovernorTracer = WithEventType InboundGovernor >$< tracer, + Diffusion.dtInboundGovernorTransitionTracer = WithEventType InboundGovernorTransition >$< tracer, + Diffusion.dtLocalConnectionManagerTracer = WithEventType LocalConnectionManager >$< tracer, + Diffusion.dtLocalServerTracer = WithEventType LocalServer >$< tracer, + Diffusion.dtLocalInboundGovernorTracer = WithEventType LocalInboundGovernor >$< tracer, + Diffusion.dtDnsTracer = WithEventType Dns >$< tracer } - where - (.-) :: Bool -> Tracer m a -> Tracer m a - True .- a = a - False .- _ = nullTracer - infixl 3 .- + diff --git a/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Examples.hs b/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Examples.hs index a19851675a..4596053273 100644 --- a/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Examples.hs +++ b/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Examples.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE PackageImports #-} + module DMQ.Protocol.LocalMsgNotification.Examples where import Control.Exception (assert) -import Control.Tracer +import "contra-tracer" Control.Tracer import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Word diff --git a/dmq-node/topology.json b/dmq-node/topology.json index 9b5f80c8c5..8a59a984b4 100644 --- a/dmq-node/topology.json +++ b/dmq-node/topology.json @@ -14,7 +14,7 @@ } ], "useLedgerAfterSlot": 128908821, - "peerSnapshotFile": "decentralized-message-queue/peer-snapshot.json", + "peerSnapshotFile": null, "extraConfig": {} }