diff --git a/cabal.project b/cabal.project index fcdbe06513..843a28b1a2 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-11-07T15:42:47Z +-- `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: c33672805ce56fdbbb29fcab5e64d30c88277857 + --sha256: 04gsn3r1znqydmjlbipwlrvwk2yq91hg6rv92b3dzphiqrrlfgsr + packages: ./cardano-ping ./monoidal-synchronisation ./network-mux diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index 0e43055298..2c4af0f031 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 (traceWith) import Data.Act -import Data.Aeson (ToJSON) import Data.Functor.Contravariant ((>$<)) import Data.Maybe (maybeToList) import Data.Text qualified as Text @@ -36,8 +36,10 @@ import DMQ.NodeToNode (NodeToNodeVersion, dmqCodecs, dmqLimitsAndTimeouts, ntnApps) import DMQ.Protocol.LocalMsgSubmission.Codec import DMQ.Protocol.SigSubmission.Type (Sig (..)) -import DMQ.Tracer - +import DMQ.Tracer ( + mkCardanoTracer + , WithEventType (WithEventType), EventType (DMQ) + ) import DMQ.Diffusion.PeerSelection (policy) import Ouroboros.Network.Diffusion qualified as Diffusion import Ouroboros.Network.PeerSelection.PeerSharing.Codec (decodeRemoteAddress, @@ -66,16 +68,14 @@ 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, + dmqcShelleyGenesisFile = I genesisFile, dmqcVersion = I version } = config' <> commandLineConfig `act` defaultConfiguration - let tracer :: ToJSON ev => Tracer IO (WithEventType ev) - tracer = dmqTracer prettyLog + + (tracer, dmqDiffusionTracers) <- mkCardanoTracer configFilePath when version $ do let gitrev = $(gitRev) @@ -94,9 +94,15 @@ runDMQ commandLineConfig = do ] exitSuccess - traceWith tracer (WithEventType "Configuration" dmqConfig) + traceWith tracer (WithEventType (DMQ "Configuration") dmqConfig) + res <- KES.evolutionConfigFromGenesisFile genesisFile + evolutionConfig <- case res of + Left err -> traceWith tracer (WithEventType (DMQ "ShelleyGenesisFile") err) + >> throwIO (userError $ err) + Right ev -> return ev + nt <- readTopologyFileOrError topologyFile - traceWith tracer (WithEventType "NetworkTopology" nt) + traceWith tracer (WithEventType (DMQ "NetworkTopology") nt) stdGen <- newStdGen let (psRng, policyRng) = split stdGen @@ -128,12 +134,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 @@ -144,6 +146,6 @@ runDMQ commandLineConfig = do (policy policyRng) Diffusion.run dmqDiffusionArguments - (dmqDiffusionTracers dmqConfig tracer) + dmqDiffusionTracers dmqDiffusionConfiguration dmqDiffusionApplications 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 8e53316f15..64d397117e 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -92,6 +92,8 @@ library base16-bytestring, bytestring >=0.10 && <0.13, cardano-binary, + -- TODO + --cardano-diffusion:logging, cardano-crypto-class, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.9, @@ -107,12 +109,16 @@ library kes-agent-crypto ^>=0.1, network ^>=3.2.7, network-mux ^>=0.9.1, + network-mux:cardano-logging, optparse-applicative >=0.18 && <0.20, ouroboros-network:{ouroboros-network, api, framework, orphan-instances, protocols} ^>=0.23, + ouroboros-network:cardano-logging, + ouroboros-network:framework-cardano-logging, random ^>=1.2, singletons, text >=1.2.4 && <2.2, time >=1.12 && <1.16, + trace-dispatcher ^>= 2.10.0, typed-protocols:{typed-protocols, cborg} ^>=1.1, hs-source-dirs: src @@ -132,7 +138,6 @@ executable dmq-node build-depends: acts, - aeson, base, cardano-git-rev, contra-tracer >=0.1 && <0.3, @@ -141,7 +146,7 @@ executable dmq-node optparse-applicative, ouroboros-network:{ouroboros-network, api}, random, - text, + text hs-source-dirs: app default-language: Haskell2010 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 95ffbff5aa..188109fd2c 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 @@ -112,7 +112,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) @@ -120,9 +120,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, @@ -132,9 +130,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 61b52cddbb..e2948dcf2c 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PackageImports #-} module DMQ.NodeToNode ( RemoteAddress @@ -34,7 +35,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 @@ -59,7 +60,7 @@ import Cardano.Crypto.KES.Class qualified as KES import Cardano.KESAgent.KES.Crypto (Crypto (..)) import Cardano.KESAgent.KES.OCert (OCertSignable) -import DMQ.Configuration (Configuration, Configuration' (..), I (..)) +import DMQ.Configuration (Configuration) import DMQ.Diffusion.NodeKernel (NodeKernel (..)) import DMQ.NodeToNode.Version import DMQ.Protocol.SigSubmission.Codec @@ -170,7 +171,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 @@ -179,18 +180,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 @@ -249,18 +239,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 @@ -274,9 +260,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 @@ -287,18 +271,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 @@ -318,9 +298,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 @@ -348,9 +326,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 @@ -374,9 +350,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 @@ -396,9 +370,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..83275c5d80 100644 --- a/dmq-node/src/DMQ/Tracer.hs +++ b/dmq-node/src/DMQ/Tracer.hs @@ -4,12 +4,13 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} module DMQ.Tracer - ( dmqTracer - , dmqDiffusionTracers + ( mkCardanoTracer + , EventType (..) , WithEventType (..) , NoExtraPeers (..) , NoExtraState (..) @@ -23,16 +24,21 @@ 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.Functor.Contravariant ((>$<)) +import Data.Aeson.KeyMap (fromList) import Data.Set qualified as Set import Data.Text qualified as Text +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Encoding (decodeUtf8) + +-- TODO +--import Cardano.Network.Logging () +import Network.Mux.Logging () +import Ouroboros.Network.Logging () +import Ouroboros.Network.Logging.Framework () import Ouroboros.Network.Diffusion qualified as Diffusion import Ouroboros.Network.OrphanInstances () @@ -42,38 +48,306 @@ 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 = 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 _ = [] + +instance Logging.MetaTrace WithEventType where + -- allNamespaces :: [Namespace a] + allNamespaces = [ + -- DMQ-Node only traces. + ------------------------ + -- Main. + Logging.Namespace [] ["Configuration"] + , Logging.Namespace [] ["ShelleyGenesisFile"] + , 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.Outbound"] + , Logging.Namespace [] ["SigSubmission.Protocol.Client"] + , Logging.Namespace [] ["SigSubmission.Protocol.Server"] + ] + namespaceFor (WithEventType et _) = Logging.Namespace [] [(Text.pack $ show et)] + severityFor _ _ = Just Logging.Info + privacyFor _ _ = Just Logging.Public + detailsFor _ _ = Just Logging.DNormal + documentFor _ = Nothing + metricsDocFor _ = [] + +mkCardanoTracer :: FilePath + -> IO ( + Tracer IO WithEventType + , Diffusion.Tracers + RemoteAddress + NodeToNodeVersion + NodeToNodeVersionData + LocalAddress + NodeToClientVersion + NodeToClientVersionData + NoExtraState + NoExtraDebugState + NoExtraFlags + NoExtraPeers + NoExtraCounters + NoExtraTracer + IO + ) +mkCardanoTracer dmqConfigFilePath = do + traceConfig <- Logging.readConfiguration dmqConfigFilePath + emptyConfigReflection <- Logging.emptyConfigReflection + stdoutTrace <- Logging.standardTracer + let trForward = mempty + let mbTrEkg = Nothing + {-- 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) + --} + -- This is a `Logging.Trace IO WithEventType`. + cardanoTracer <- 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 + [cardanoTracer] -data WithEventType a = WithEventType String a - deriving Show -instance ToJSON a => ToJSON (WithEventType a) where - toJSON (WithEventType eventType a) = toJSON (eventType, a) + -- Make it a "contra-tracer" tracer for backward compatibility. + -- This is a `Tracer IO WithEventType`. + let dmqTracer = contramapM + (\wet@(WithEventType _ _) -> do + Logging.traceWith cardanoTracer wet + ) + $ Tracer (\_ -> return ()) --- | 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 } - ) - $ Tracer LBS.Char8.putStrLn + !dtMuxTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Mux", "Remote"] + Logging.configureTracers emptyConfigReflection traceConfig [dtMuxTracer] + !dtChannelTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Mux", "Remote", "Channel"] + Logging.configureTracers emptyConfigReflection traceConfig [dtChannelTracer] + !dtBearerTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Mux", "Remote", "Bearer"] + Logging.configureTracers emptyConfigReflection traceConfig [dtBearerTracer] + !dtHandshakeTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Handshake", "Remote"] + Logging.configureTracers emptyConfigReflection traceConfig [dtHandshakeTracer] + !dtLocalMuxTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Mux", "Local"] + Logging.configureTracers emptyConfigReflection traceConfig [dtLocalMuxTracer] + !dtLocalChannelTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Mux", "Local", "Channel"] + Logging.configureTracers emptyConfigReflection traceConfig [dtLocalChannelTracer] + !dtLocalBearerTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Mux", "Local", "Bearer"] + Logging.configureTracers emptyConfigReflection traceConfig [dtLocalBearerTracer] + !dtLocalHandshakeTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Handshake", "Local"] + Logging.configureTracers emptyConfigReflection traceConfig [dtLocalHandshakeTracer] + !dtDiffusionTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Startup", "DiffusionInit"] + Logging.configureTracers emptyConfigReflection traceConfig [dtDiffusionTracer] + !dtTraceLocalRootPeersTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Peers", "LocalRoot"] + Logging.configureTracers emptyConfigReflection traceConfig [dtTraceLocalRootPeersTracer] + !dtTracePublicRootPeersTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Peers", "PublicRoot"] + Logging.configureTracers emptyConfigReflection traceConfig [dtTracePublicRootPeersTracer] + !dtTraceLedgerPeersTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Peers", "Ledger"] + Logging.configureTracers emptyConfigReflection traceConfig [dtTraceLedgerPeersTracer] + !dtTracePeerSelectionTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "PeerSelection", "Selection"] + Logging.configureTracers emptyConfigReflection traceConfig [dtTracePeerSelectionTracer] + !dtDebugPeerSelectionInitiatorTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "PeerSelection", "Initiator"] + Logging.configureTracers emptyConfigReflection traceConfig [dtDebugPeerSelectionInitiatorTracer] + !dtDebugPeerSelectionInitiatorResponderTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "PeerSelection", "Responder"] + Logging.configureTracers emptyConfigReflection traceConfig [dtDebugPeerSelectionInitiatorResponderTracer] + !dtTraceChurnCounters <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Churn"] + Logging.configureTracers emptyConfigReflection traceConfig [dtTraceChurnCounters] + !dtTracePeerSelectionCounters <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "PeerSelection"] + Logging.configureTracers emptyConfigReflection traceConfig [dtTracePeerSelectionCounters] + !dtPeerSelectionActionsTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "PeerSelection", "Actions"] + Logging.configureTracers emptyConfigReflection traceConfig [dtPeerSelectionActionsTracer] + !dtConnectionManagerTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "ConnectionManager", "Remote"] + Logging.configureTracers emptyConfigReflection traceConfig [dtConnectionManagerTracer] + !dtConnectionManagerTransitionTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "ConnectionManager", "Transition"] + Logging.configureTracers emptyConfigReflection traceConfig [dtConnectionManagerTransitionTracer] + !dtServerTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Server", "Local"] + Logging.configureTracers emptyConfigReflection traceConfig [dtServerTracer] + !dtInboundGovernorTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "InboundGovernor", "Remote"] + Logging.configureTracers emptyConfigReflection traceConfig [dtInboundGovernorTracer] + !dtInboundGovernorTransitionTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "InboundGovernor", "Transition"] + Logging.configureTracers emptyConfigReflection traceConfig [dtInboundGovernorTransitionTracer] + !dtLocalConnectionManagerTracer <- Logging.mkCardanoTracer + stdoutTrace trForward Nothing -- never conflate metrics of the same name with those originating from `connectionManagerTr` + ["Net", "ConnectionManager", "Local"] + Logging.configureTracers emptyConfigReflection traceConfig [dtLocalConnectionManagerTracer] + !dtLocalServerTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "Server", "Local"] + Logging.configureTracers emptyConfigReflection traceConfig [dtLocalServerTracer] + !dtLocalInboundGovernorTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "InboundGovernor", "Local"] + Logging.configureTracers emptyConfigReflection traceConfig [dtLocalInboundGovernorTracer] + !dtDnsTracer <- Logging.mkCardanoTracer + stdoutTrace trForward mbTrEkg + ["Net", "DNS"] + Logging.configureTracers emptyConfigReflection traceConfig [dtDnsTracer] + + let dmqDifussionTracers = + -- From `Cardano.Node.Tracing.Tracers` + -- Branch "ana/10.6-final-integration-mix" +{-- +Diffusion.Tracers { + Diffusion.dtMuxTracer = Tracer $ traceWith dtMuxTracer +, Diffusion.dtChannelTracer = Tracer $ traceWith dtChannelTracer +, Diffusion.dtBearerTracer = Tracer $ traceWith dtBearerTracer +, Diffusion.dtHandshakeTracer = Tracer $ traceWith dtHandshakeTracer +, Diffusion.dtLocalMuxTracer = Tracer $ traceWith dtLocalMuxTracer +, Diffusion.dtLocalChannelTracer = Tracer $ traceWith dtLocalChannelTracer +, Diffusion.dtLocalBearerTracer = Tracer $ traceWith dtLocalBearerTracer +, Diffusion.dtLocalHandshakeTracer = Tracer $ traceWith dtLocalHandshakeTracer +, Diffusion.dtDiffusionTracer = Tracer $ traceWith dtDiffusionTracer +, Diffusion.dtTraceLocalRootPeersTracer = Tracer $ traceWith localRootPeersTr +, Diffusion.dtTracePublicRootPeersTracer = Tracer $ traceWith publicRootPeersTr +, Diffusion.dtTraceLedgerPeersTracer = Tracer $ traceWith dtTraceLedgerPeersTracer +, Diffusion.dtTracePeerSelectionTracer = Tracer $ traceWith dtTracePeerSelectionTracer +, Diffusion.dtDebugPeerSelectionInitiatorTracer = Tracer $ traceWith dtDebugPeerSelectionInitiatorTracer +, Diffusion.dtDebugPeerSelectionInitiatorResponderTracer = Tracer $ traceWith dtDebugPeerSelectionInitiatorResponderTracer + +, Diffusion.dtTracePeerSelectionCounters = Tracer $ traceWith peerSelectionCountersTr +, Diffusion.dtTraceChurnCounters = Tracer $ traceWith churnCountersTr +, Diffusion.dtPeerSelectionActionsTracer = Tracer $ traceWith peerSelectionActionsTr +, Diffusion.dtConnectionManagerTracer = Tracer $ traceWith dtConnectionManagerTracer +, Diffusion.dtConnectionManagerTransitionTracer = Tracer $ traceWith dtConnectionManagerTransitionTracer +, Diffusion.dtServerTracer = Tracer $ traceWith serverTr +, Diffusion.dtInboundGovernorTracer = Tracer $ traceWith inboundGovernorTr +, Diffusion.dtInboundGovernorTransitionTracer = Tracer $ traceWith inboundGovernorTransitionsTr +, Diffusion.dtDnsTracer = Tracer $ traceWith dtDnsTr +, Diffusion.dtLocalConnectionManagerTracer = Tracer $ traceWith localConnectionManagerTr +, Diffusion.dtLocalServerTracer = Tracer $ traceWith localServerTr +, Diffusion.dtLocalInboundGovernorTracer = Tracer $ traceWith localInboundGovernorTr +} +--} + Diffusion.Tracers { + Diffusion.dtMuxTracer = Tracer $ Logging.traceWith dtMuxTracer, + Diffusion.dtChannelTracer = Tracer $ Logging.traceWith dtChannelTracer, + Diffusion.dtBearerTracer = Tracer $ Logging.traceWith dtBearerTracer, + Diffusion.dtHandshakeTracer = Tracer $ Logging.traceWith dtHandshakeTracer, + Diffusion.dtLocalMuxTracer = Tracer $ Logging.traceWith dtLocalMuxTracer, + Diffusion.dtLocalChannelTracer = Tracer $ Logging.traceWith dtLocalChannelTracer, + Diffusion.dtLocalBearerTracer = Tracer $ Logging.traceWith dtLocalBearerTracer, + Diffusion.dtLocalHandshakeTracer = Tracer $ Logging.traceWith dtLocalHandshakeTracer, + Diffusion.dtDiffusionTracer = Tracer $ Logging.traceWith dtDiffusionTracer, + Diffusion.dtTraceLocalRootPeersTracer = Tracer $ Logging.traceWith dtTraceLocalRootPeersTracer, + Diffusion.dtTracePublicRootPeersTracer = Tracer $ Logging.traceWith dtTracePublicRootPeersTracer, + Diffusion.dtTraceLedgerPeersTracer = Tracer $ Logging.traceWith dtTraceLedgerPeersTracer, + Diffusion.dtTracePeerSelectionTracer = Tracer $ Logging.traceWith dtTracePeerSelectionTracer, + Diffusion.dtDebugPeerSelectionInitiatorTracer = Tracer $ Logging.traceWith dtDebugPeerSelectionInitiatorTracer, + Diffusion.dtDebugPeerSelectionInitiatorResponderTracer = Tracer $ Logging.traceWith dtDebugPeerSelectionInitiatorResponderTracer, + Diffusion.dtTraceChurnCounters = Tracer $ Logging.traceWith dtTraceChurnCounters, + Diffusion.dtTracePeerSelectionCounters = Tracer $ Logging.traceWith dtTracePeerSelectionCounters, + Diffusion.dtPeerSelectionActionsTracer = Tracer $ Logging.traceWith dtPeerSelectionActionsTracer, + Diffusion.dtConnectionManagerTracer = Tracer $ Logging.traceWith dtConnectionManagerTracer, + Diffusion.dtConnectionManagerTransitionTracer = Tracer $ Logging.traceWith dtConnectionManagerTransitionTracer, + Diffusion.dtServerTracer = Tracer $ Logging.traceWith dtServerTracer, + Diffusion.dtInboundGovernorTracer = Tracer $ Logging.traceWith dtInboundGovernorTracer, + Diffusion.dtInboundGovernorTransitionTracer = Tracer $ Logging.traceWith dtInboundGovernorTransitionTracer, + Diffusion.dtLocalConnectionManagerTracer = Tracer $ Logging.traceWith dtLocalConnectionManagerTracer, + Diffusion.dtLocalServerTracer = Tracer $ Logging.traceWith dtLocalServerTracer, + Diffusion.dtLocalInboundGovernorTracer = Tracer $ Logging.traceWith dtLocalInboundGovernorTracer, + Diffusion.dtDnsTracer = Tracer $ Logging.traceWith dtDnsTracer + } + + return (dmqTracer, dmqDifussionTracers) -- An orphan instance needed for `Handshake versionNumber Term` instance ToJSON Term where @@ -84,7 +358,8 @@ instance Semigroup NoExtraPeers where _ <> _ = NoExtraPeers instance Monoid NoExtraPeers where mempty = NoExtraPeers - +instance Show NoExtraPeers where + show _ = "" instance ToJSON NoExtraPeers where toJSON _ = Null omitField _ = True @@ -105,6 +380,12 @@ instance ToJSON NoExtraDebugState where data NoExtraChurnArgs = NoExtraChurnArgs data NoExtraAPI = NoExtraAPI data NoExtraTracer = NoExtraTracer +instance Show NoExtraState where + show _ = "" +instance Show NoExtraDebugState where + show _ = "" +instance Show NoExtraTracer where + show _ = "" instance ToJSON NoExtraTracer where toJSON _ = Null omitField _ = True @@ -156,110 +437,3 @@ instance ToJSON (DebugPeerSelection NoExtraState NoExtraFlags NoExtraPeers Remot (const NoExtraCounters) st ] - -dmqDiffusionTracers - :: forall m. - Applicative m - => Configuration - -> (forall ev. ToJSON ev => Tracer m (WithEventType ev)) - -> Diffusion.Tracers RemoteAddress NodeToNodeVersion NodeToNodeVersionData - LocalAddress NodeToClientVersion NodeToClientVersionData - NoExtraState - NoExtraDebugState - NoExtraFlags - NoExtraPeers - 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 - } - 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": {} } diff --git a/network-mux/cardano-logging/Network/Mux/Logging.hs b/network-mux/cardano-logging/Network/Mux/Logging.hs new file mode 100644 index 0000000000..25bd0adfdf --- /dev/null +++ b/network-mux/cardano-logging/Network/Mux/Logging.hs @@ -0,0 +1,527 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.Diffusion`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Network.Mux.Logging () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +import Data.Typeable +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (Value (String), (.=)) +-------------------------- +-- Package: "formatting" - +-------------------------- +import "formatting" Formatting +--------------------------- +-- Package: "network-mux" - +--------------------------- +import qualified "network-mux" -- "network-mux:network-mux" + Network.Mux as Mux +#ifdef linux_HOST_OS +import "network-mux" -- "network-mux:network-mux" + Network.Mux.TCPInfo (StructTCPInfo (..)) +#endif +import "network-mux" -- "network-mux:network-mux" + Network.Mux.Types + ( SDUHeader (..), unRemoteClockModel + ) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +-------------------------------------------------------------------------------- +-- Mux Tracer +-------------------------------------------------------------------------------- + +instance (LogFormatting peer, LogFormatting tr, Typeable tr) => + LogFormatting (Mux.WithBearer peer tr) where + forMachine dtal (Mux.WithBearer b ev) = + mconcat [ "kind" .= (show . typeOf $ ev) + , "bearer" .= forMachine dtal b + , "event" .= forMachine dtal ev ] + forHuman (Mux.WithBearer b ev) = "With mux bearer " <> forHumanOrMachine b + <> ". " <> forHumanOrMachine ev + +instance MetaTrace tr => MetaTrace (Mux.WithBearer peer tr) where + namespaceFor (Mux.WithBearer _peer obj) = (nsCast . namespaceFor) obj + severityFor ns Nothing = severityFor (nsCast ns :: Namespace tr) Nothing + severityFor ns (Just (Mux.WithBearer _peer obj)) = + severityFor (nsCast ns) (Just obj) + privacyFor ns Nothing = privacyFor (nsCast ns :: Namespace tr) Nothing + privacyFor ns (Just (Mux.WithBearer _peer obj)) = + privacyFor (nsCast ns) (Just obj) + detailsFor ns Nothing = detailsFor (nsCast ns :: Namespace tr) Nothing + detailsFor ns (Just (Mux.WithBearer _peer obj)) = + detailsFor (nsCast ns) (Just obj) + documentFor ns = documentFor (nsCast ns :: Namespace tr) + metricsDocFor ns = metricsDocFor (nsCast ns :: Namespace tr) + allNamespaces = map nsCast (allNamespaces :: [Namespace tr]) + +instance LogFormatting Mux.BearerTrace where + forMachine _dtal Mux.TraceRecvHeaderStart = mconcat + [ "kind" .= String "Mux.TraceRecvHeaderStart" + , "msg" .= String "Bearer Receive Header Start" + ] + forMachine _dtal (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + [ "kind" .= String "Mux.TraceRecvHeaderStart" + , "msg" .= String "Bearer Receive Header End" + , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "miniProtocolNum" .= String (showT mhNum) + , "miniProtocolDir" .= String (showT mhDir) + , "length" .= String (showT mhLength) + ] + forMachine _dtal (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = mconcat + [ "kind" .= String "Mux.TraceRecvDeltaQObservation" + , "msg" .= String "Bearer DeltaQ observation" + , "timeRemote" .= String (showT ts) + , "timeLocal" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "length" .= String (showT mhLength) + ] + forMachine _dtal (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = mconcat + [ "kind" .= String "Mux.TraceRecvDeltaQSample" + , "msg" .= String "Bearer DeltaQ Sample" + , "duration" .= String (showT d) + , "packets" .= String (showT sp) + , "sumBytes" .= String (showT so) + , "DeltaQ_S" .= String (showT dqs) + , "DeltaQ_VMean" .= String (showT dqvm) + , "DeltaQ_VVar" .= String (showT dqvs) + , "DeltaQ_estR" .= String (showT estR) + , "sizeDist" .= String (showT sdud) + ] + forMachine _dtal (Mux.TraceRecvStart len) = mconcat + [ "kind" .= String "Mux.TraceRecvStart" + , "msg" .= String "Bearer Receive Start" + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceRecvRaw len) = mconcat + [ "kind" .= String "Mux.TraceRecvRaw" + , "msg" .= String "Bearer Receive Raw" + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceRecvEnd len) = mconcat + [ "kind" .= String "Mux.TraceRecvEnd" + , "msg" .= String "Bearer Receive End" + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + [ "kind" .= String "Mux.TraceSendStart" + , "msg" .= String "Bearer Send Start" + , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "miniProtocolNum" .= String (showT mhNum) + , "miniProtocolDir" .= String (showT mhDir) + , "length" .= String (showT mhLength) + ] + forMachine _dtal Mux.TraceSendEnd = mconcat + [ "kind" .= String "Mux.TraceSendEnd" + , "msg" .= String "Bearer Send End" + ] + forMachine _dtal Mux.TraceSDUReadTimeoutException = mconcat + [ "kind" .= String "Mux.TraceSDUReadTimeoutException" + , "msg" .= String "Timed out reading SDU" + ] + forMachine _dtal Mux.TraceSDUWriteTimeoutException = mconcat + [ "kind" .= String "Mux.TraceSDUWriteTimeoutException" + , "msg" .= String "Timed out writing SDU" + ] + forMachine _dtal Mux.TraceEmitDeltaQ = mempty +#ifdef linux_HOST_OS + forMachine _dtal (Mux.TraceTCPInfo StructTCPInfo + { tcpi_snd_mss, tcpi_rcv_mss, tcpi_lost, tcpi_retrans + , tcpi_rtt, tcpi_rttvar, tcpi_snd_cwnd } + len) = mconcat + [ "kind" .= String "Mux.TraceTCPInfo" + , "msg" .= String "TCPInfo" + , "rtt" .= (fromIntegral tcpi_rtt :: Word) + , "rttvar" .= (fromIntegral tcpi_rttvar :: Word) + , "snd_cwnd" .= (fromIntegral tcpi_snd_cwnd :: Word) + , "snd_mss" .= (fromIntegral tcpi_snd_mss :: Word) + , "rcv_mss" .= (fromIntegral tcpi_rcv_mss :: Word) + , "lost" .= (fromIntegral tcpi_lost :: Word) + , "retrans" .= (fromIntegral tcpi_retrans :: Word) + , "length" .= len + ] +#else + forMachine _dtal (Mux.TraceTCPInfo _ len) = mconcat + [ "kind" .= String "Mux.TraceTCPInfo" + , "msg" .= String "TCPInfo" + , "len" .= String (showT len) + ] +#endif + + forHuman Mux.TraceRecvHeaderStart = + "Bearer Receive Header Start" + forHuman (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = + sformat ("Bearer Receive Header End: ts:" % prefixHex % "(" % shown % ") " % shown % " len " % int) + (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength + forHuman (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = + sformat ("Bearer DeltaQ observation: remote ts" % int % " local ts " % shown % " length " % int) + (unRemoteClockModel mhTimestamp) ts mhLength + forHuman (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = + sformat ("Bearer DeltaQ Sample: duration " % fixed 3 % " packets " % int % " sumBytes " + % int % " DeltaQ_S " % fixed 3 % " DeltaQ_VMean " % fixed 3 % "DeltaQ_VVar " % fixed 3 + % " DeltaQ_estR " % fixed 3 % " sizeDist " % string) + d sp so dqs dqvm dqvs estR sdud + forHuman (Mux.TraceRecvStart len) = + sformat ("Bearer Receive Start: length " % int) len + forHuman (Mux.TraceRecvRaw len) = + sformat ("Bearer Receive Raw: length " % int) len + forHuman (Mux.TraceRecvEnd len) = + sformat ("Bearer Receive End: length " % int) len + forHuman (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = + sformat ("Bearer Send Start: ts: " % prefixHex % " (" % shown % ") " % shown % " length " % int) + (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength + forHuman Mux.TraceSendEnd = + "Bearer Send End" + forHuman Mux.TraceSDUReadTimeoutException = + "Timed out reading SDU" + forHuman Mux.TraceSDUWriteTimeoutException = + "Timed out writing SDU" + forHuman Mux.TraceEmitDeltaQ = mempty +#ifdef linux_HOST_OS + forHuman (Mux.TraceTCPInfo StructTCPInfo + { tcpi_snd_mss, tcpi_rcv_mss, tcpi_lost, tcpi_retrans + , tcpi_rtt, tcpi_rttvar, tcpi_snd_cwnd } + len) = + sformat ("TCPInfo rtt " % int % " rttvar " % int % " snd_cwnd " % int % + " snd_mss " % int % " rcv_mss " % int % " lost " % int % + " retrans " % int % " len " % int) + (fromIntegral tcpi_rtt :: Word) + (fromIntegral tcpi_rttvar :: Word) + (fromIntegral tcpi_snd_cwnd :: Word) + (fromIntegral tcpi_snd_mss :: Word) + (fromIntegral tcpi_rcv_mss :: Word) + (fromIntegral tcpi_lost :: Word) + (fromIntegral tcpi_retrans :: Word) + len +#else + forHuman (Mux.TraceTCPInfo _ len) = sformat ("TCPInfo len " % int) len +#endif + +instance MetaTrace Mux.BearerTrace where + namespaceFor Mux.TraceRecvHeaderStart {} = + Namespace [] ["RecvHeaderStart"] + namespaceFor Mux.TraceRecvHeaderEnd {} = + Namespace [] ["RecvHeaderEnd"] + namespaceFor Mux.TraceRecvStart {} = + Namespace [] ["RecvStart"] + namespaceFor Mux.TraceRecvRaw {} = + Namespace [] ["RecvRaw"] + namespaceFor Mux.TraceRecvEnd {} = + Namespace [] ["RecvEnd"] + namespaceFor Mux.TraceSendStart {} = + Namespace [] ["SendStart"] + namespaceFor Mux.TraceSendEnd = + Namespace [] ["SendEnd"] + namespaceFor Mux.TraceRecvDeltaQObservation {} = + Namespace [] ["RecvDeltaQObservation"] + namespaceFor Mux.TraceRecvDeltaQSample {} = + Namespace [] ["RecvDeltaQSample"] + namespaceFor Mux.TraceSDUReadTimeoutException = + Namespace [] ["SDUReadTimeoutException"] + namespaceFor Mux.TraceSDUWriteTimeoutException = + Namespace [] ["SDUWriteTimeoutException"] + namespaceFor Mux.TraceEmitDeltaQ = + Namespace [] ["TraceEmitDeltaQ"] + namespaceFor Mux.TraceTCPInfo {} = + Namespace [] ["TCPInfo"] + + severityFor (Namespace _ ["RecvHeaderStart"]) _ = Just Debug + severityFor (Namespace _ ["RecvRaw"]) _ = Just Debug + severityFor (Namespace _ ["RecvHeaderEnd"]) _ = Just Debug + severityFor (Namespace _ ["RecvStart"]) _ = Just Debug + severityFor (Namespace _ ["RecvEnd"]) _ = Just Debug + severityFor (Namespace _ ["SendStart"]) _ = Just Debug + severityFor (Namespace _ ["SendEnd"]) _ = Just Debug + severityFor (Namespace _ ["RecvDeltaQObservation"]) _ = Just Debug + severityFor (Namespace _ ["RecvDeltaQSample"]) _ = Just Debug + severityFor (Namespace _ ["SDUReadTimeoutException"]) _ = Just Notice + severityFor (Namespace _ ["SDUWriteTimeoutException"]) _ = Just Notice + severityFor (Namespace _ ["TCPInfo"]) _ = Just Debug + severityFor (Namespace _ ["TraceEmitDeltaQ"]) _ = Nothing + severityFor _ _ = Nothing + + documentFor (Namespace _ ["RecvHeaderStart"]) = Just + "Bearer receive header start." + documentFor (Namespace _ ["RecvRaw"]) = Just + "Bearer receive raw." + documentFor (Namespace _ ["RecvHeaderEnd"]) = Just + "Bearer receive header end." + documentFor (Namespace _ ["RecvStart"]) = Just + "Bearer receive start." + documentFor (Namespace _ ["RecvEnd"]) = Just + "Bearer receive end." + documentFor (Namespace _ ["SendStart"]) = Just + "Bearer send start." + documentFor (Namespace _ ["SendEnd"]) = Just + "Bearer send end." + documentFor (Namespace _ ["RecvDeltaQObservation"]) = Just + "Bearer DeltaQ observation." + documentFor (Namespace _ ["RecvDeltaQSample"]) = Just + "Bearer DeltaQ sample." + documentFor (Namespace _ ["SDUReadTimeoutException"]) = Just + "Timed out reading SDU." + documentFor (Namespace _ ["SDUWriteTimeoutException"]) = Just + "Timed out writing SDU." + documentFor (Namespace _ ["TraceEmitDeltaQ"]) = Nothing + documentFor (Namespace _ ["TCPInfo"]) = Just + "TCPInfo." + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["RecvHeaderStart"] + , Namespace [] ["RecvRaw"] + , Namespace [] ["RecvHeaderEnd"] + , Namespace [] ["RecvStart"] + , Namespace [] ["RecvEnd"] + , Namespace [] ["SendStart"] + , Namespace [] ["SendEnd"] + , Namespace [] ["RecvDeltaQObservation"] + , Namespace [] ["RecvDeltaQSample"] + , Namespace [] ["SDUReadTimeoutException"] + , Namespace [] ["SDUWriteTimeoutException"] + , Namespace [] ["TraceEmitDeltaQ"] + , Namespace [] ["TCPInfo"] + ] + +instance LogFormatting Mux.ChannelTrace where + forMachine _dtal (Mux.TraceChannelRecvStart mid) = mconcat + [ "kind" .= String "Mux.TraceChannelRecvStart" + , "msg" .= String "Channel Receive Start" + , "miniProtocolNum" .= String (showT mid) + ] + forMachine _dtal (Mux.TraceChannelRecvEnd mid len) = mconcat + [ "kind" .= String "Mux.TraceChannelRecvEnd" + , "msg" .= String "Channel Receive End" + , "miniProtocolNum" .= String (showT mid) + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceChannelSendStart mid len) = mconcat + [ "kind" .= String "Mux.TraceChannelSendStart" + , "msg" .= String "Channel Send Start" + , "miniProtocolNum" .= String (showT mid) + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceChannelSendEnd mid) = mconcat + [ "kind" .= String "Mux.TraceChannelSendEnd" + , "msg" .= String "Channel Send End" + , "miniProtocolNum" .= String (showT mid) + ] + + forHuman (Mux.TraceChannelRecvStart mid) = + sformat ("Channel Receive Start on " % shown) mid + forHuman (Mux.TraceChannelRecvEnd mid len) = + sformat ("Channel Receive End on (" % shown % ") " % int) mid len + forHuman (Mux.TraceChannelSendStart mid len) = + sformat ("Channel Send Start on (" % shown % ") " % int) mid len + forHuman (Mux.TraceChannelSendEnd mid) = + sformat ("Channel Send End on " % shown) mid + +instance MetaTrace Mux.ChannelTrace where + namespaceFor Mux.TraceChannelRecvStart {} = + Namespace [] ["ChannelRecvStart"] + namespaceFor Mux.TraceChannelRecvEnd {} = + Namespace [] ["ChannelRecvEnd"] + namespaceFor Mux.TraceChannelSendStart {} = + Namespace [] ["ChannelSendStart"] + namespaceFor Mux.TraceChannelSendEnd {} = + Namespace [] ["ChannelSendEnd"] + + severityFor (Namespace _ ["ChannelRecvStart"]) _ = Just Debug + severityFor (Namespace _ ["ChannelRecvEnd"]) _ = Just Debug + severityFor (Namespace _ ["ChannelSendStart"]) _ = Just Debug + severityFor (Namespace _ ["ChannelSendEnd"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ChannelRecvStart"]) = Just + "Channel receive start." + documentFor (Namespace _ ["ChannelRecvEnd"]) = Just + "Channel receive end." + documentFor (Namespace _ ["ChannelSendStart"]) = Just + "Channel send start." + documentFor (Namespace _ ["ChannelSendEnd"]) = Just + "Channel send end." + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["ChannelRecvStart"] + , Namespace [] ["ChannelRecvEnd"] + , Namespace [] ["ChannelSendStart"] + , Namespace [] ["ChannelSendEnd"] + ] + +instance LogFormatting Mux.Trace where + forMachine _dtal (Mux.TraceState new) = mconcat + [ "kind" .= String "Mux.TraceState" + , "msg" .= String "MuxState" + , "state" .= String (showT new) + ] + forMachine _dtal (Mux.TraceCleanExit mid dir) = mconcat + [ "kind" .= String "Mux.TraceCleanExit" + , "msg" .= String "Miniprotocol terminated cleanly" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceExceptionExit mid dir exc) = mconcat + [ "kind" .= String "Mux.TraceExceptionExit" + , "msg" .= String "Miniprotocol terminated with exception" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + , "exception" .= String (showT exc) + ] + forMachine _dtal (Mux.TraceStartEagerly mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartEagerly" + , "msg" .= String "Eagerly started" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceStartOnDemand mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartOnDemand" + , "msg" .= String "Preparing to start" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceStartOnDemandAny mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartOnDemandAny" + , "msg" .= String "Preparing to start" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceStartedOnDemand mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartedOnDemand" + , "msg" .= String "Started on demand" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceTerminating mid dir) = mconcat + [ "kind" .= String "Mux.TraceTerminating" + , "msg" .= String "Terminating" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal Mux.TraceStopping = mconcat + [ "kind" .= String "Mux.TraceStopping" + , "msg" .= String "Mux stopping" + ] + forMachine _dtal Mux.TraceStopped = mconcat + [ "kind" .= String "Mux.TraceStopped" + , "msg" .= String "Mux stoppped" + ] + + forMachine _dtal (Mux.TraceNewMux _) = mconcat [] + forMachine _dtal Mux.TraceStarting = mconcat [] + + forHuman (Mux.TraceState new) = + sformat ("State: " % shown) new + forHuman (Mux.TraceCleanExit mid dir) = + sformat ("Miniprotocol (" % shown % ") " % shown % " terminated cleanly") + mid dir + forHuman (Mux.TraceExceptionExit mid dir e) = + sformat ("Miniprotocol (" % shown % ") " % shown % + " terminated with exception " % shown) mid dir e + forHuman (Mux.TraceStartEagerly mid dir) = + sformat ("Eagerly started (" % shown % ") in " % shown) mid dir + forHuman (Mux.TraceStartOnDemand mid dir) = + sformat ("Preparing to start (" % shown % ") in " % shown) mid dir + forHuman (Mux.TraceStartOnDemandAny mid dir) = + sformat ("Preparing to start (" % shown % ") in " % shown) mid dir + forHuman (Mux.TraceStartedOnDemand mid dir) = + sformat ("Started on demand (" % shown % ") in " % shown) mid dir + forHuman (Mux.TraceTerminating mid dir) = + sformat ("Terminating (" % shown % ") in " % shown) mid dir + forHuman Mux.TraceStopping = "Mux stopping" + forHuman Mux.TraceStopped = "Mux stoppped" + + forHuman (Mux.TraceNewMux _) = "" + forHuman Mux.TraceStarting = "" + +instance MetaTrace Mux.Trace where + namespaceFor Mux.TraceState {} = + Namespace [] ["State"] + namespaceFor Mux.TraceCleanExit {} = + Namespace [] ["CleanExit"] + namespaceFor Mux.TraceExceptionExit {} = + Namespace [] ["ExceptionExit"] + namespaceFor Mux.TraceStartEagerly {} = + Namespace [] ["StartEagerly"] + namespaceFor Mux.TraceStartOnDemand {} = + Namespace [] ["StartOnDemand"] + namespaceFor Mux.TraceStartOnDemandAny {} = + Namespace [] ["StartOnDemandAny"] + namespaceFor Mux.TraceStartedOnDemand {} = + Namespace [] ["StartedOnDemand"] + namespaceFor Mux.TraceTerminating {} = + Namespace [] ["Terminating"] + namespaceFor Mux.TraceStopping = + Namespace [] ["Stopping"] + namespaceFor Mux.TraceStopped = + Namespace [] ["Stopped"] + + namespaceFor (Mux.TraceNewMux _) = Namespace [] [] + namespaceFor Mux.TraceStarting = Namespace [] [] + + severityFor (Namespace _ ["State"]) _ = Just Info + severityFor (Namespace _ ["CleanExit"]) _ = Just Notice + severityFor (Namespace _ ["ExceptionExit"]) _ = Just Notice + severityFor (Namespace _ ["StartEagerly"]) _ = Just Debug + severityFor (Namespace _ ["StartOnDemand"]) _ = Just Debug + severityFor (Namespace _ ["StartOnDemandAny"]) _ = Just Debug + severityFor (Namespace _ ["StartedOnDemand"]) _ = Just Debug + severityFor (Namespace _ ["Terminating"]) _ = Just Debug + severityFor (Namespace _ ["Stopping"]) _ = Just Debug + severityFor (Namespace _ ["Stopped"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["State"]) = Just + "State." + documentFor (Namespace _ ["CleanExit"]) = Just + "Miniprotocol terminated cleanly." + documentFor (Namespace _ ["ExceptionExit"]) = Just + "Miniprotocol terminated with exception." + documentFor (Namespace _ ["StartEagerly"]) = Just + "Eagerly started." + documentFor (Namespace _ ["StartOnDemand"]) = Just + "Preparing to start." + documentFor (Namespace _ ["StartedOnDemand"]) = Just + "Started on demand." + documentFor (Namespace _ ["StartOnDemandAny"]) = Just + "Start whenever any other protocol has started." + documentFor (Namespace _ ["Terminating"]) = Just + "Terminating." + documentFor (Namespace _ ["Stopping"]) = Just + "Mux shutdown." + documentFor (Namespace _ ["Stopped"]) = Just + "Mux shutdown." + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["State"] + , Namespace [] ["CleanExit"] + , Namespace [] ["ExceptionExit"] + , Namespace [] ["StartEagerly"] + , Namespace [] ["StartOnDemand"] + , Namespace [] ["StartOnDemandAny"] + , Namespace [] ["StartedOnDemand"] + , Namespace [] ["Terminating"] + , Namespace [] ["Stopping"] + , Namespace [] ["Stopped"] + ] + diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 300883fe02..63376fc25c 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -113,6 +113,30 @@ library -Wredundant-constraints -Wunused-packages +library cardano-logging + build-depends: + aeson, + base >=4.14 && <4.22, + formatting, + network-mux, + trace-dispatcher ^>= 2.10.0 + hs-source-dirs: cardano-logging + visibility: public + exposed-modules: + Network.Mux.Logging + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wno-unticked-promoted-constructors + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging.hs new file mode 100644 index 0000000000..02df14fc01 --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.Diffusion`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +import qualified Data.List as List +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (Value (String), (.=)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import qualified "ouroboros-network" -- "ouroboros-network:ouroboros-network" + Ouroboros.Network.Diffusion.Types as Diff +-- Needed for `instance ToJSON UseLedgerPeers`. +import "ouroboros-network" -- "ouroboros-network:orphan-instances" + Ouroboros.Network.OrphanInstances () +import "ouroboros-network" -- "ouroboros-network:ouroboros-network" + Ouroboros.Network.PeerSelection.LedgerPeers + ( NumberOfPeers (..) + , PoolStake (..) + , TraceLedgerPeers (..) + ) +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging +--------- +-- Self - +--------- +import Ouroboros.Network.Logging.PeerSelection.ChurnCounters () +import Ouroboros.Network.Logging.PeerSelection.Governor () +import Ouroboros.Network.Logging.PeerSelection.PeerStateActions () +import Ouroboros.Network.Logging.PeerSelection.RootPeersDNS.DNSActions () +import Ouroboros.Network.Logging.PeerSelection.RootPeersDNS.LocalRootPeers () +import Ouroboros.Network.Logging.PeerSelection.RootPeersDNS.PublicRootPeers () + +-------------------------------------------------------------------------------- +-- DiffusionInit Tracer. +-------------------------------------------------------------------------------- + +instance (Show ntnAddr, Show ntcAddr) => + LogFormatting (Diff.DiffusionTracer ntnAddr ntcAddr) where + forMachine _dtal (Diff.RunServer sockAddr) = mconcat + [ "kind" .= String "RunServer" + , "socketAddress" .= String (pack (show sockAddr)) + ] + + forMachine _dtal (Diff.RunLocalServer localAddress) = mconcat + [ "kind" .= String "RunLocalServer" + , "localAddress" .= String (pack (show localAddress)) + ] + forMachine _dtal (Diff.UsingSystemdSocket localAddress) = mconcat + [ "kind" .= String "UsingSystemdSocket" + , "path" .= String (pack . show $ localAddress) + ] + + forMachine _dtal (Diff.CreateSystemdSocketForSnocketPath localAddress) = mconcat + [ "kind" .= String "CreateSystemdSocketForSnocketPath" + , "path" .= String (pack . show $ localAddress) + ] + forMachine _dtal (Diff.CreatedLocalSocket localAddress) = mconcat + [ "kind" .= String "CreatedLocalSocket" + , "path" .= String (pack . show $ localAddress) + ] + forMachine _dtal (Diff.ConfiguringLocalSocket localAddress socket) = mconcat + [ "kind" .= String "ConfiguringLocalSocket" + , "path" .= String (pack . show $ localAddress) + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.ListeningLocalSocket localAddress socket) = mconcat + [ "kind" .= String "ListeningLocalSocket" + , "path" .= String (pack . show $ localAddress) + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.LocalSocketUp localAddress fd) = mconcat + [ "kind" .= String "LocalSocketUp" + , "path" .= String (pack . show $ localAddress) + , "socket" .= String (pack (show fd)) + ] + forMachine _dtal (Diff.CreatingServerSocket socket) = mconcat + [ "kind" .= String "CreatingServerSocket" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.ListeningServerSocket socket) = mconcat + [ "kind" .= String "ListeningServerSocket" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.ServerSocketUp socket) = mconcat + [ "kind" .= String "ServerSocketUp" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.ConfiguringServerSocket socket) = mconcat + [ "kind" .= String "ConfiguringServerSocket" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.UnsupportedLocalSystemdSocket path) = mconcat + [ "kind" .= String "UnsupportedLocalSystemdSocket" + , "path" .= String (pack (show path)) + ] + forMachine _dtal Diff.UnsupportedReadySocketCase = mconcat + [ "kind" .= String "UnsupportedReadySocketCase" + ] + forMachine _dtal (Diff.DiffusionErrored exception) = mconcat + [ "kind" .= String "DiffusionErrored" + , "error" .= String (pack (show exception)) + ] + forMachine _dtal (Diff.SystemdSocketConfiguration config) = mconcat + [ "kind" .= String "SystemdSocketConfiguration" + , "path" .= String (pack (show config)) + ] + +instance MetaTrace (Diff.DiffusionTracer ntnAddr ntcAddr) where + namespaceFor Diff.RunServer {} = + Namespace [] ["RunServer"] + namespaceFor Diff.RunLocalServer {} = + Namespace [] ["RunLocalServer"] + namespaceFor Diff.UsingSystemdSocket {} = + Namespace [] ["UsingSystemdSocket"] + namespaceFor Diff.CreateSystemdSocketForSnocketPath {} = + Namespace [] ["CreateSystemdSocketForSnocketPath"] + namespaceFor Diff.CreatedLocalSocket {} = + Namespace [] ["CreatedLocalSocket"] + namespaceFor Diff.ConfiguringLocalSocket {} = + Namespace [] ["ConfiguringLocalSocket"] + namespaceFor Diff.ListeningLocalSocket {} = + Namespace [] ["ListeningLocalSocket"] + namespaceFor Diff.LocalSocketUp {} = + Namespace [] ["LocalSocketUp"] + namespaceFor Diff.CreatingServerSocket {} = + Namespace [] ["CreatingServerSocket"] + namespaceFor Diff.ListeningServerSocket {} = + Namespace [] ["ListeningServerSocket"] + namespaceFor Diff.ServerSocketUp {} = + Namespace [] ["ServerSocketUp"] + namespaceFor Diff.ConfiguringServerSocket {} = + Namespace [] ["ConfiguringServerSocket"] + namespaceFor Diff.UnsupportedLocalSystemdSocket {} = + Namespace [] ["UnsupportedLocalSystemdSocket"] + namespaceFor Diff.UnsupportedReadySocketCase {} = + Namespace [] ["UnsupportedReadySocketCase"] + namespaceFor Diff.DiffusionErrored {} = + Namespace [] ["DiffusionErrored"] + namespaceFor Diff.SystemdSocketConfiguration {} = + Namespace [] ["SystemdSocketConfiguration"] + + severityFor (Namespace _ ["RunServer"]) _ = Just Info + severityFor (Namespace _ ["RunLocalServer"]) _ = Just Info + severityFor (Namespace _ ["UsingSystemdSocket"]) _ = Just Info + severityFor (Namespace _ ["CreateSystemdSocketForSnocketPath"]) _ = Just Info + severityFor (Namespace _ ["CreatedLocalSocket"]) _ = Just Info + severityFor (Namespace _ ["ConfiguringLocalSocket"]) _ = Just Info + severityFor (Namespace _ ["ListeningLocalSocket"]) _ = Just Info + severityFor (Namespace _ ["LocalSocketUp"]) _ = Just Info + severityFor (Namespace _ ["CreatingServerSocket"]) _ = Just Info + severityFor (Namespace _ ["ListeningServerSocket"]) _ = Just Info + severityFor (Namespace _ ["ServerSocketUp"]) _ = Just Info + severityFor (Namespace _ ["ConfiguringServerSocket"]) _ = Just Info + severityFor (Namespace _ ["UnsupportedLocalSystemdSocket"]) _ = Just Warning + severityFor (Namespace _ ["UnsupportedReadySocketCase"]) _ = Just Info + severityFor (Namespace _ ["DiffusionErrored"]) _ = Just Critical + severityFor (Namespace _ ["SystemdSocketConfiguration"]) _ = Just Warning + severityFor _ _ = Nothing + + documentFor (Namespace _ ["RunServer"]) = Just + "RunServer" + documentFor (Namespace _ ["RunLocalServer"]) = Just + "RunLocalServer" + documentFor (Namespace _ ["UsingSystemdSocket"]) = Just + "UsingSystemdSocket" + documentFor (Namespace _ ["CreateSystemdSocketForSnocketPath"]) = Just + "CreateSystemdSocketForSnocketPath" + documentFor (Namespace _ ["CreatedLocalSocket"]) = Just + "CreatedLocalSocket" + documentFor (Namespace _ ["ConfiguringLocalSocket"]) = Just + "ConfiguringLocalSocket" + documentFor (Namespace _ ["ListeningLocalSocket"]) = Just + "ListeningLocalSocket" + documentFor (Namespace _ ["LocalSocketUp"]) = Just + "LocalSocketUp" + documentFor (Namespace _ ["CreatingServerSocket"]) = Just + "CreatingServerSocket" + documentFor (Namespace _ ["ListeningServerSocket"]) = Just + "ListeningServerSocket" + documentFor (Namespace _ ["ServerSocketUp"]) = Just + "ServerSocketUp" + documentFor (Namespace _ ["ConfiguringServerSocket"]) = Just + "ConfiguringServerSocket" + documentFor (Namespace _ ["UnsupportedLocalSystemdSocket"]) = Just + "UnsupportedLocalSystemdSocket" + documentFor (Namespace _ ["UnsupportedReadySocketCase"]) = Just + "UnsupportedReadySocketCase" + documentFor (Namespace _ ["DiffusionErrored"]) = Just + "DiffusionErrored" + documentFor (Namespace _ ["SystemdSocketConfiguration"]) = Just + "SystemdSocketConfiguration" + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["RunServer"] + , Namespace [] ["RunLocalServer"] + , Namespace [] ["UsingSystemdSocket"] + , Namespace [] ["CreateSystemdSocketForSnocketPath"] + , Namespace [] ["CreatedLocalSocket"] + , Namespace [] ["ConfiguringLocalSocket"] + , Namespace [] ["ListeningLocalSocket"] + , Namespace [] ["LocalSocketUp"] + , Namespace [] ["CreatingServerSocket"] + , Namespace [] ["ListeningServerSocket"] + , Namespace [] ["ServerSocketUp"] + , Namespace [] ["ConfiguringServerSocket"] + , Namespace [] ["UnsupportedLocalSystemdSocket"] + , Namespace [] ["UnsupportedReadySocketCase"] + , Namespace [] ["DiffusionErrored"] + , Namespace [] ["SystemdSocketConfiguration"] + ] + +-------------------------------------------------------------------------------- +-- LedgerPeers Tracer. +-------------------------------------------------------------------------------- + +instance LogFormatting TraceLedgerPeers where + forMachine _dtal (PickedLedgerPeer addr _ackStake stake) = + mconcat + [ "kind" .= String "PickedLedgerPeer" + , "address" .= show addr + , "relativeStake" .= (realToFrac (unPoolStake stake) :: Double) + ] + forMachine _dtal (PickedLedgerPeers (NumberOfPeers n) addrs) = + mconcat + [ "kind" .= String "PickedLedgerPeers" + , "desiredCount" .= n + , "count" .= List.length addrs + , "addresses" .= show addrs + ] + forMachine _dtal (PickedBigLedgerPeer addr _ackStake stake) = + mconcat + [ "kind" .= String "PickedBigLedgerPeer" + , "address" .= show addr + , "relativeStake" .= (realToFrac (unPoolStake stake) :: Double) + ] + forMachine _dtal (PickedBigLedgerPeers (NumberOfPeers n) addrs) = + mconcat + [ "kind" .= String "PickedBigLedgerPeers" + , "desiredCount" .= n + , "count" .= List.length addrs + , "addresses" .= show addrs + ] + forMachine _dtal (FetchingNewLedgerState cnt bigCnt) = + mconcat + [ "kind" .= String "FetchingNewLedgerState" + , "numberOfLedgerPeers" .= cnt + , "numberOfBigLedgerPeers" .= bigCnt + ] + forMachine _dtal DisabledLedgerPeers = + mconcat + [ "kind" .= String "DisabledLedgerPeers" + ] + forMachine _dtal (TraceUseLedgerPeers ulp) = + mconcat + [ "kind" .= String "UseLedgerPeers" + , "useLedgerPeers" .= ulp + ] + forMachine _dtal WaitingOnRequest = + mconcat + [ "kind" .= String "WaitingOnRequest" + ] + forMachine _dtal (RequestForPeers (NumberOfPeers np)) = + mconcat + [ "kind" .= String "RequestForPeers" + , "numberOfPeers" .= np + ] + forMachine _dtal (ReusingLedgerState cnt age) = + mconcat + [ "kind" .= String "ReusingLedgerState" + , "numberOfPools" .= cnt + , "ledgerStateAge" .= age + ] + forMachine _dtal FallingBackToPublicRootPeers = + mconcat + [ "kind" .= String "FallingBackToPublicRootPeers" + ] + forMachine _dtal (NotEnoughLedgerPeers (NumberOfPeers target) numOfLedgerPeers) = + mconcat + [ "kind" .= String "NotEnoughLedgerPeers" + , "target" .= target + , "numOfLedgerPeers" .= numOfLedgerPeers + ] + forMachine _dtal (NotEnoughBigLedgerPeers (NumberOfPeers target) numOfBigLedgerPeers) = + mconcat + [ "kind" .= String "NotEnoughBigLedgerPeers" + , "target" .= target + , "numOfBigLedgerPeers" .= numOfBigLedgerPeers + ] + forMachine _dtal (TraceLedgerPeersDomains daps) = + mconcat + [ "kind" .= String "TraceLedgerPeersDomains" + , "domainAccessPoints" .= daps + ] + forMachine _dtal UsingBigLedgerPeerSnapshot = + mconcat + [ "kind" .= String "UsingBigLedgerPeerSnapshot" + ] + +instance MetaTrace TraceLedgerPeers where + namespaceFor PickedLedgerPeer {} = + Namespace [] ["PickedLedgerPeer"] + namespaceFor PickedLedgerPeers {} = + Namespace [] ["PickedLedgerPeers"] + namespaceFor PickedBigLedgerPeer {} = + Namespace [] ["PickedBigLedgerPeer"] + namespaceFor PickedBigLedgerPeers {} = + Namespace [] ["PickedBigLedgerPeers"] + namespaceFor FetchingNewLedgerState {} = + Namespace [] ["FetchingNewLedgerState"] + namespaceFor DisabledLedgerPeers {} = + Namespace [] ["DisabledLedgerPeers"] + namespaceFor TraceUseLedgerPeers {} = + Namespace [] ["TraceUseLedgerPeers"] + namespaceFor WaitingOnRequest {} = + Namespace [] ["WaitingOnRequest"] + namespaceFor RequestForPeers {} = + Namespace [] ["RequestForPeers"] + namespaceFor ReusingLedgerState {} = + Namespace [] ["ReusingLedgerState"] + namespaceFor FallingBackToPublicRootPeers {} = + Namespace [] ["FallingBackToPublicRootPeers"] + namespaceFor NotEnoughLedgerPeers {} = + Namespace [] ["NotEnoughLedgerPeers"] + namespaceFor NotEnoughBigLedgerPeers {} = + Namespace [] ["NotEnoughBigLedgerPeers"] + namespaceFor TraceLedgerPeersDomains {} = + Namespace [] ["TraceLedgerPeersDomains"] + namespaceFor UsingBigLedgerPeerSnapshot {} = + Namespace [] ["UsingBigLedgerPeerSnapshot"] + + severityFor (Namespace _ ["PickedLedgerPeer"]) _ = Just Debug + severityFor (Namespace _ ["PickedLedgerPeers"]) _ = Just Info + severityFor (Namespace _ ["PickedBigLedgerPeer"]) _ = Just Debug + severityFor (Namespace _ ["PickedBigLedgerPeers"]) _ = Just Info + severityFor (Namespace _ ["FetchingNewLedgerState"]) _ = Just Info + severityFor (Namespace _ ["DisabledLedgerPeers"]) _ = Just Info + severityFor (Namespace _ ["TraceUseLedgerAfter"]) _ = Just Info + severityFor (Namespace _ ["WaitingOnRequest"]) _ = Just Debug + severityFor (Namespace _ ["RequestForPeers"]) _ = Just Debug + severityFor (Namespace _ ["ReusingLedgerState"]) _ = Just Debug + severityFor (Namespace _ ["FallingBackToPublicRootPeers"]) _ = Just Info + severityFor (Namespace _ ["NotEnoughLedgerPeers"]) _ = Just Warning + severityFor (Namespace _ ["NotEnoughBigLedgerPeers"]) _ = Just Warning + severityFor (Namespace _ ["TraceLedgerPeersDomains"]) _ = Just Debug + severityFor (Namespace _ ["UsingBigLedgerPeerSnapshot"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["PickedLedgerPeer"]) = Just + "Trace for a peer picked with accumulated and relative stake of its pool." + documentFor (Namespace _ ["PickedLedgerPeers"]) = Just + "Trace for the number of peers we wanted to pick and the list of peers picked." + documentFor (Namespace _ ["PickedBigLedgerPeer"]) = Just + "Trace for a big ledger peer picked with accumulated and relative stake of its pool." + documentFor (Namespace _ ["PickedBigLedgerPeers"]) = Just + "Trace for the number of big ledger peers we wanted to pick and the list of peers picked." + documentFor (Namespace _ ["FetchingNewLedgerState"]) = Just $ mconcat + [ "Trace for fetching a new list of peers from the ledger. Int is the number of peers" + , " returned." + ] + documentFor (Namespace _ ["DisabledLedgerPeers"]) = Just + "Trace for when getting peers from the ledger is disabled, that is DontUseLedger." + documentFor (Namespace _ ["TraceUseLedgerAfter"]) = Just + "Trace UseLedgerAfter value." + documentFor (Namespace _ ["WaitingOnRequest"]) = Just + "" + documentFor (Namespace _ ["RequestForPeers"]) = Just + "RequestForPeers (NumberOfPeers 1)" + documentFor (Namespace _ ["ReusingLedgerState"]) = Just + "" + documentFor (Namespace _ ["FallingBackToPublicRootPeers"]) = Just + "" + documentFor (Namespace _ ["TraceLedgerPeersDomains"]) = Just + "" + documentFor (Namespace _ ["UsingBigLedgerPeerSnapshot"]) = Just $ mconcat + [ "Trace for when a request for big ledger peers is fulfilled from the snapshot file" + , " specified in the topology file."] + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["PickedLedgerPeer"] + , Namespace [] ["PickedLedgerPeers"] + , Namespace [] ["PickedBigLedgerPeer"] + , Namespace [] ["PickedBigLedgerPeers"] + , Namespace [] ["FetchingNewLedgerState"] + , Namespace [] ["DisabledLedgerPeers"] + , Namespace [] ["TraceUseLedgerAfter"] + , Namespace [] ["WaitingOnRequest"] + , Namespace [] ["RequestForPeers"] + , Namespace [] ["ReusingLedgerState"] + , Namespace [] ["FallingBackToPublicRootPeers"] + , Namespace [] ["NotEnoughLedgerPeers"] + , Namespace [] ["NotEnoughBigLedgerPeers"] + , Namespace [] ["TraceLedgerPeersDomains"] + , Namespace [] ["UsingBigLedgerPeerSnapshot"] + ] + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/ChurnCounters.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/ChurnCounters.hs new file mode 100644 index 0000000000..c2296a21b8 --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/ChurnCounters.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.ChurnCounters () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (Value (String), (.=)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import "ouroboros-network" -- "ouroboros-network:ouroboros-network" + Ouroboros.Network.PeerSelection.Churn + ( ChurnCounters (..) ) +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +-------------------------------------------------------------------------------- +-- ChurnCounters Tracer. +-------------------------------------------------------------------------------- + +instance LogFormatting ChurnCounters where + forMachine _dtal (ChurnCounter action c) = + mconcat [ "kind" .= String "ChurnCounter" + , "action" .= String (pack $ show action) + , "counter" .= c + ] + asMetrics (ChurnCounter action c) = + [ IntM + ("peerSelection.churn." <> pack (show action)) + (fromIntegral c) + ] + +instance MetaTrace ChurnCounters where + namespaceFor ChurnCounter {} = Namespace [] ["ChurnCounters"] + + severityFor (Namespace _ ["ChurnCounters"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ChurnCounters"]) = Just + "churn counters" + documentFor _ = Nothing + + metricsDocFor (Namespace _ ["ChurnCounters"]) = + [ ("peerSelection.churn.DecreasedActivePeers", "number of decreased active peers") + , ("peerSelection.churn.IncreasedActivePeers", "number of increased active peers") + , ("peerSelection.churn.DecreasedActiveBigLedgerPeers", "number of decreased active big ledger peers") + , ("peerSelection.churn.IncreasedActiveBigLedgerPeers", "number of increased active big ledger peers") + , ("peerSelection.churn.DecreasedEstablishedPeers", "number of decreased established peers") + , ("peerSelection.churn.IncreasedEstablishedPeers", "number of increased established peers") + , ("peerSelection.churn.IncreasedEstablishedBigLedgerPeers", "number of increased established big ledger peers") + , ("peerSelection.churn.DecreasedEstablishedBigLedgerPeers", "number of decreased established big ledger peers") + , ("peerSelection.churn.DecreasedKnownPeers", "number of decreased known peers") + , ("peerSelection.churn.IncreasedKnownPeers", "number of increased known peers") + , ("peerSelection.churn.DecreasedKnownBigLedgerPeers", "number of decreased known big ledger peers") + , ("peerSelection.churn.IncreasedKnownBigLedgerPeers", "number of increased known big ledger peers") + ] + metricsDocFor _ = [] + + allNamespaces =[ + Namespace [] ["ChurnCounters"] + ] + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor.hs new file mode 100644 index 0000000000..658d4be820 --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.Governor () where + +-------------------------------------------------------------------------------- + +--------- +-- Self - +--------- +import Ouroboros.Network.Logging.PeerSelection.Governor.DebugPeerSelection () +import Ouroboros.Network.Logging.PeerSelection.Governor.PeerSelectionCounters () +import Ouroboros.Network.Logging.PeerSelection.Governor.TracePeerSelection () + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/DebugPeerSelection.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/DebugPeerSelection.hs new file mode 100644 index 0000000000..b54fc96f76 --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/DebugPeerSelection.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +{- TODO: All references to package "cardano-diffusion" were removed. +-- See all the TODO annotations. +import "cardano-diffusion" -- "cardano-diffusion:???" + Cardano.Network.PeerSelection.Governor.Monitor + ( ExtraTrace (TraceLedgerStateJudgementChanged, TraceUseBootstrapPeersChanged) + ) +--} + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.Governor.DebugPeerSelection () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (Value (String), (.=)) +----------------------- +-- Package: "network" - +----------------------- +import "network" Network.Socket (SockAddr) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import "ouroboros-network" -- "ouroboros-network:ouroboros-network" + Ouroboros.Network.PeerSelection.Governor.Types + ( DebugPeerSelection (..) + , PeerSelectionState (..) + ) +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging +--------- +-- Self - +--------- +import Ouroboros.Network.Logging.PeerSelection.Governor.Utils + ( peerSelectionTargetsToObject + ) + +-------------------------------------------------------------------------------- +-- DebugPeerSelection Tracer +-------------------------------------------------------------------------------- + +{-- TODO: Before "cardano-diffusion" removal: +instance LogFormatting (DebugPeerSelection Cardano.ExtraState PeerTrustable (Cardano.PublicRootPeers.ExtraPeers SockAddr) SockAddr) where +--} +instance ( Show extraState + , Show extraFlags + , Show extraPeers + ) + => LogFormatting (DebugPeerSelection extraState extraFlags extraPeers SockAddr) where + forMachine _dtal@DNormal (TraceGovernorState blockedAt wakeupAfter + _st@PeerSelectionState { targets }) = + mconcat [ "kind" .= String "DebugPeerSelection" + , "blockedAt" .= String (pack $ show blockedAt) + , "wakeupAfter" .= String (pack $ show wakeupAfter) + , "targets" .= peerSelectionTargetsToObject targets +{-- TODO:Before "cardano-diffusion" removal: + + , "counters" .= forMachine dtal (peerSelectionStateToCounters Cardano.PublicRootPeers.toSet Cardano.cardanoPeerSelectionStatetoCounters st) +--} + ] + forMachine _ (TraceGovernorState blockedAt wakeupAfter ev) = + mconcat [ "kind" .= String "DebugPeerSelection" + , "blockedAt" .= String (pack $ show blockedAt) + , "wakeupAfter" .= String (pack $ show wakeupAfter) + , "peerSelectionState" .= String (pack $ show ev) + ] + forHuman = pack . show + +instance MetaTrace (DebugPeerSelection extraState extraFlags extraPeers SockAddr) where + namespaceFor TraceGovernorState {} = Namespace [] ["GovernorState"] + + severityFor (Namespace _ ["GovernorState"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["GovernorState"]) = Just "" + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["GovernorState"] + ] + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/PeerSelectionCounters.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/PeerSelectionCounters.hs new file mode 100644 index 0000000000..49ae5b3db7 --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/PeerSelectionCounters.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +{- TODO: All references to package "cardano-diffusion" were removed. +-- See all the TODO annotations. +import "cardano-diffusion" -- "cardano-diffusion:???" + Cardano.Network.PeerSelection.Governor.Monitor + ( ExtraTrace (TraceLedgerStateJudgementChanged, TraceUseBootstrapPeersChanged) + ) +--} + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.Governor.PeerSelectionCounters () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (Value (String), (.=)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import "ouroboros-network" -- "ouroboros-network:ouroboros-network" + Ouroboros.Network.PeerSelection.Governor.Types + ( PeerSelectionCounters + , PeerSelectionView (..) + ) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +-------------------------------------------------------------------------------- +-- PeerSelectionCounters +-------------------------------------------------------------------------------- + +{-- TODO: Before "cardano-diffusion" removal: +: +instance LogFormatting (PeerSelectionCounters (Cardano.ExtraPeerSelectionSetsWithSizes addr)) where +--} +instance LogFormatting (PeerSelectionCounters extraCounters) where + forMachine _dtal PeerSelectionCounters {..} = + mconcat [ "kind" .= String "PeerSelectionCounters" + + , "knownPeers" .= numberOfKnownPeers + , "rootPeers" .= numberOfRootPeers + , "coldPeersPromotions" .= numberOfColdPeersPromotions + , "establishedPeers" .= numberOfEstablishedPeers + , "warmPeersDemotions" .= numberOfWarmPeersDemotions + , "warmPeersPromotions" .= numberOfWarmPeersPromotions + , "activePeers" .= numberOfActivePeers + , "activePeersDemotions" .= numberOfActivePeersDemotions + + , "knownBigLedgerPeers" .= numberOfKnownBigLedgerPeers + , "coldBigLedgerPeersPromotions" .= numberOfColdBigLedgerPeersPromotions + , "establishedBigLedgerPeers" .= numberOfEstablishedBigLedgerPeers + , "warmBigLedgerPeersDemotions" .= numberOfWarmBigLedgerPeersDemotions + , "warmBigLedgerPeersPromotions" .= numberOfWarmBigLedgerPeersPromotions + , "activeBigLedgerPeers" .= numberOfActiveBigLedgerPeers + , "activeBigLedgerPeersDemotions" .= numberOfActiveBigLedgerPeersDemotions + + , "knownLocalRootPeers" .= numberOfKnownLocalRootPeers + , "establishedLocalRootPeers" .= numberOfEstablishedLocalRootPeers + , "warmLocalRootPeersPromotions" .= numberOfWarmLocalRootPeersPromotions + , "activeLocalRootPeers" .= numberOfActiveLocalRootPeers + , "activeLocalRootPeersDemotions" .= numberOfActiveLocalRootPeersDemotions + + , "knownNonRootPeers" .= numberOfKnownNonRootPeers + , "coldNonRootPeersPromotions" .= numberOfColdNonRootPeersPromotions + , "establishedNonRootPeers" .= numberOfEstablishedNonRootPeers + , "warmNonRootPeersDemotions" .= numberOfWarmNonRootPeersDemotions + , "warmNonRootPeersPromotions" .= numberOfWarmNonRootPeersPromotions + , "activeNonRootPeers" .= numberOfActiveNonRootPeers + , "activeNonRootPeersDemotions" .= numberOfActiveNonRootPeersDemotions +{-- TODO: Before "cardano-diffusion" removal: +: + , "knownBootstrapPeers" .= snd (Cardano.viewKnownBootstrapPeers extraCounters) + , "coldBootstrapPeersPromotions" .= snd (Cardano.viewColdBootstrapPeersPromotions extraCounters) + , "establishedBootstrapPeers" .= snd (Cardano.viewEstablishedBootstrapPeers extraCounters) + , "warmBootstrapPeersDemotions" .= snd (Cardano.viewWarmBootstrapPeersDemotions extraCounters) + , "warmBootstrapPeersPromotions" .= snd (Cardano.viewWarmBootstrapPeersPromotions extraCounters) + , "activeBootstrapPeers" .= snd (Cardano.viewActiveBootstrapPeers extraCounters) + , "ActiveBootstrapPeersDemotions" .= snd (Cardano.viewActiveBootstrapPeersDemotions extraCounters) +--} + ] + forHuman = forHumanFromMachine + asMetrics psc = + case psc of + PeerSelectionCountersHWC {..} -> + -- Deprecated metrics; they will be removed in a future version. + [ IntM + "peerSelection.Cold" + (fromIntegral numberOfColdPeers) + , IntM + "peerSelection.Warm" + (fromIntegral numberOfWarmPeers) + , IntM + "peerSelection.Hot" + (fromIntegral numberOfHotPeers) + , IntM + "peerSelection.ColdBigLedgerPeers" + (fromIntegral numberOfColdBigLedgerPeers) + , IntM + "peerSelection.WarmBigLedgerPeers" + (fromIntegral numberOfWarmBigLedgerPeers) + , IntM + "peerSelection.HotBigLedgerPeers" + (fromIntegral numberOfHotBigLedgerPeers) + + , IntM + "peerSelection.WarmLocalRoots" + (fromIntegral $ numberOfActiveLocalRootPeers psc) + , IntM + "peerSelection.HotLocalRoots" + (fromIntegral $ numberOfEstablishedLocalRootPeers psc + - numberOfActiveLocalRootPeers psc) + ] + ++ + case psc of + PeerSelectionCounters {..} -> + [ IntM "peerSelection.RootPeers" (fromIntegral numberOfRootPeers) + + , IntM "peerSelection.KnownPeers" (fromIntegral numberOfKnownPeers) + , IntM "peerSelection.ColdPeersPromotions" (fromIntegral numberOfColdPeersPromotions) + , IntM "peerSelection.EstablishedPeers" (fromIntegral numberOfEstablishedPeers) + , IntM "peerSelection.WarmPeersDemotions" (fromIntegral numberOfWarmPeersDemotions) + , IntM "peerSelection.WarmPeersPromotions" (fromIntegral numberOfWarmPeersPromotions) + , IntM "peerSelection.ActivePeers" (fromIntegral numberOfActivePeers) + , IntM "peerSelection.ActivePeersDemotions" (fromIntegral numberOfActivePeersDemotions) + + , IntM "peerSelection.KnownBigLedgerPeers" (fromIntegral numberOfKnownBigLedgerPeers) + , IntM "peerSelection.ColdBigLedgerPeersPromotions" (fromIntegral numberOfColdBigLedgerPeersPromotions) + , IntM "peerSelection.EstablishedBigLedgerPeers" (fromIntegral numberOfEstablishedBigLedgerPeers) + , IntM "peerSelection.WarmBigLedgerPeersDemotions" (fromIntegral numberOfWarmBigLedgerPeersDemotions) + , IntM "peerSelection.WarmBigLedgerPeersPromotions" (fromIntegral numberOfWarmBigLedgerPeersPromotions) + , IntM "peerSelection.ActiveBigLedgerPeers" (fromIntegral numberOfActiveBigLedgerPeers) + , IntM "peerSelection.ActiveBigLedgerPeersDemotions" (fromIntegral numberOfActiveBigLedgerPeersDemotions) + + , IntM "peerSelection.KnownLocalRootPeers" (fromIntegral numberOfKnownLocalRootPeers) + , IntM "peerSelection.EstablishedLocalRootPeers" (fromIntegral numberOfEstablishedLocalRootPeers) + , IntM "peerSelection.WarmLocalRootPeersPromotions" (fromIntegral numberOfWarmLocalRootPeersPromotions) + , IntM "peerSelection.ActiveLocalRootPeers" (fromIntegral numberOfActiveLocalRootPeers) + , IntM "peerSelection.ActiveLocalRootPeersDemotions" (fromIntegral numberOfActiveLocalRootPeersDemotions) + + + , IntM "peerSelection.KnownNonRootPeers" (fromIntegral numberOfKnownNonRootPeers) + , IntM "peerSelection.ColdNonRootPeersPromotions" (fromIntegral numberOfColdNonRootPeersPromotions) + , IntM "peerSelection.EstablishedNonRootPeers" (fromIntegral numberOfEstablishedNonRootPeers) + , IntM "peerSelection.WarmNonRootPeersDemotions" (fromIntegral numberOfWarmNonRootPeersDemotions) + , IntM "peerSelection.WarmNonRootPeersPromotions" (fromIntegral numberOfWarmNonRootPeersPromotions) + , IntM "peerSelection.ActiveNonRootPeers" (fromIntegral numberOfActiveNonRootPeers) + , IntM "peerSelection.ActiveNonRootPeersDemotions" (fromIntegral numberOfActiveNonRootPeersDemotions) +{-- TODO: Before "cardano-diffusion" removal: +: + , IntM "peerSelection.KnownBootstrapPeers" (fromIntegral $ snd $ Cardano.viewKnownBootstrapPeers extraCounters) + , IntM "peerSelection.ColdBootstrapPeersPromotions" (fromIntegral $ snd $ Cardano.viewColdBootstrapPeersPromotions extraCounters) + , IntM "peerSelection.EstablishedBootstrapPeers" (fromIntegral $ snd $ Cardano.viewEstablishedBootstrapPeers extraCounters) + , IntM "peerSelection.WarmBootstrapPeersDemotions" (fromIntegral $ snd $ Cardano.viewWarmBootstrapPeersDemotions extraCounters) + , IntM "peerSelection.WarmBootstrapPeersPromotions" (fromIntegral $ snd $ Cardano.viewWarmBootstrapPeersPromotions extraCounters) + , IntM "peerSelection.ActiveBootstrapPeers" (fromIntegral $ snd $ Cardano.viewActiveBootstrapPeers extraCounters) + , IntM "peerSelection.ActiveBootstrapPeersDemotions" (fromIntegral $ snd $ Cardano.viewActiveBootstrapPeersDemotions extraCounters) +--} + ] + +instance MetaTrace (PeerSelectionCounters extraCounters) where + namespaceFor PeerSelectionCounters {} = Namespace [] ["Counters"] + + severityFor (Namespace _ ["Counters"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["Counters"]) = Just + "Counters of selected peers" + documentFor _ = Nothing + + metricsDocFor (Namespace _ ["Counters"]) = + [ ("peerSelection.Cold", "Number of cold peers") + , ("peerSelection.Warm", "Number of warm peers") + , ("peerSelection.Hot", "Number of hot peers") + , ("peerSelection.ColdBigLedgerPeers", "Number of cold big ledger peers") + , ("peerSelection.WarmBigLedgerPeers", "Number of warm big ledger peers") + , ("peerSelection.HotBigLedgerPeers", "Number of hot big ledger peers") + , ("peerSelection.LocalRoots", "Numbers of warm & hot local roots") + + , ("peerSelection.RootPeers", "Number of root peers") + , ("peerSelection.KnownPeers", "Number of known peers") + , ("peerSelection.ColdPeersPromotions", "Number of cold peers promotions") + , ("peerSelection.EstablishedPeers", "Number of established peers") + , ("peerSelection.WarmPeersDemotions", "Number of warm peers demotions") + , ("peerSelection.WarmPeersPromotions", "Number of warm peers promotions") + , ("peerSelection.ActivePeers", "Number of active peers") + , ("peerSelection.ActivePeersDemotions", "Number of active peers demotions") + + , ("peerSelection.KnownBigLedgerPeers", "Number of known big ledger peers") + , ("peerSelection.ColdBigLedgerPeersPromotions", "Number of cold big ledger peers promotions") + , ("peerSelection.EstablishedBigLedgerPeers", "Number of established big ledger peers") + , ("peerSelection.WarmBigLedgerPeersDemotions", "Number of warm big ledger peers demotions") + , ("peerSelection.WarmBigLedgerPeersPromotions", "Number of warm big ledger peers promotions") + , ("peerSelection.ActiveBigLedgerPeers", "Number of active big ledger peers") + , ("peerSelection.ActiveBigLedgerPeersDemotions", "Number of active big ledger peers demotions") + + , ("peerSelection.KnownLocalRootPeers", "Number of known local root peers") + , ("peerSelection.EstablishedLocalRootPeers", "Number of established local root peers") + , ("peerSelection.WarmLocalRootPeersPromotions", "Number of warm local root peers promotions") + , ("peerSelection.ActiveLocalRootPeers", "Number of active local root peers") + , ("peerSelection.ActiveLocalRootPeersDemotions", "Number of active local root peers demotions") + + , ("peerSelection.KnownNonRootPeers", "Number of known non root peers") + , ("peerSelection.ColdNonRootPeersPromotions", "Number of cold non root peers promotions") + , ("peerSelection.EstablishedNonRootPeers", "Number of established non root peers") + , ("peerSelection.WarmNonRootPeersDemotions", "Number of warm non root peers demotions") + , ("peerSelection.WarmNonRootPeersPromotions", "Number of warm non root peers promotions") + , ("peerSelection.ActiveNonRootPeers", "Number of active non root peers") + , ("peerSelection.ActiveNonRootPeersDemotions", "Number of active non root peers demotions") + + , ("peerSelection.KnownBootstrapPeers", "Number of known bootstrap peers") + , ("peerSelection.ColdBootstrapPeersPromotions", "Number of cold bootstrap peers promotions") + , ("peerSelection.EstablishedBootstrapPeers", "Number of established bootstrap peers") + , ("peerSelection.WarmBootstrapPeersDemotions", "Number of warm bootstrap peers demotions") + , ("peerSelection.WarmBootstrapPeersPromotions", "Number of warm bootstrap peers promotions") + , ("peerSelection.ActiveBootstrapPeers", "Number of active bootstrap peers") + , ("peerSelection.ActiveBootstrapPeersDemotions", "Number of active bootstrap peers demotions") + + ] + metricsDocFor _ = [] + + allNamespaces =[ + Namespace [] ["Counters"] + ] + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/TracePeerSelection.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/TracePeerSelection.hs new file mode 100644 index 0000000000..8f259aac66 --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/TracePeerSelection.hs @@ -0,0 +1,799 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +{- TODO: All references to package "cardano-diffusion" were removed. +-- See all the TODO annotations. +import "cardano-diffusion" -- "cardano-diffusion:???" + Cardano.Network.PeerSelection.Governor.Monitor + ( ExtraTrace (TraceLedgerStateJudgementChanged, TraceUseBootstrapPeersChanged) + ) +--} + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.Governor.TracePeerSelection () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +import Control.Exception (fromException) +import Data.Bifunctor (first) +import Data.Foldable (toList) +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (ToJSON, ToJSONKey, toJSON, toJSONList, Value (String), (.=)) +----------------------- +-- Package: "network" - +----------------------- +import "network" Network.Socket (SockAddr) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import "ouroboros-network" -- "ouroboros-network:ouroboros-network" + Ouroboros.Network.PeerSelection.Governor.Types + ( DebugPeerSelectionState (..) + , DemotionTimeoutException + , TracePeerSelection (..) + ) +import "ouroboros-network" -- "ouroboros-network:ouroboros-network" + Ouroboros.Network.PeerSelection.PublicRootPeers + ( PublicRootPeers + ) +import qualified "ouroboros-network" -- "ouroboros-newtwork:ouroboros-network" + Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers +import "ouroboros-network" -- "ouroboros-newtwork:protocols" + Ouroboros.Network.Protocol.PeerSharing.Type + ( PeerSharingAmount (PeerSharingAmount) + ) +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging +--------- +-- Self - +--------- +import Ouroboros.Network.Logging.PeerSelection.Governor.Utils + ( peerSelectionTargetsToObject + ) + +-------------------------------------------------------------------------------- +-- PeerSelection Tracer +-------------------------------------------------------------------------------- + +{-- TODO: Before "cardano-diffusion" removal: +instance LogFormatting (TracePeerSelection Cardano.DebugPeerSelectionState PeerTrustable (Cardano.PublicRootPeers.ExtraPeers SockAddr) SockAddr) where +--} +instance ( Ord ntnAddr + , Show extraDebugState + , Show extraFlags + , Show extraPeers + , Show extraTrace + , Show ntnAddr + , ToJSON extraFlags + , ToJSON ntnAddr + , ToJSON (PublicRootPeers extraPeers ntnAddr) + , ToJSONKey ntnAddr + ) + => LogFormatting (TracePeerSelection extraDebugState extraFlags extraPeers extraTrace ntnAddr) where + forMachine _dtal (TraceLocalRootPeersChanged lrp lrp') = + mconcat [ "kind" .= String "LocalRootPeersChanged" + , "previous" .= toJSON lrp + , "current" .= toJSON lrp' + ] + forMachine _dtal (TraceTargetsChanged pst pst') = + mconcat [ "kind" .= String "TargetsChanged" + , "previous" .= toJSON pst + , "current" .= toJSON pst' + ] + forMachine _dtal (TracePublicRootsRequest tRootPeers nRootPeers) = + mconcat [ "kind" .= String "PublicRootsRequest" + , "targetNumberOfRootPeers" .= tRootPeers + , "numberOfRootPeers" .= nRootPeers + ] + forMachine _dtal (TracePublicRootsResults res group dt) = + mconcat [ "kind" .= String "PublicRootsResults" + , "result" .= toJSON res + , "group" .= group + , "diffTime" .= dt + ] + forMachine _dtal (TracePublicRootsFailure err group dt) = + mconcat [ "kind" .= String "PublicRootsFailure" + , "reason" .= show err + , "group" .= group + , "diffTime" .= dt + ] + forMachine _dtal (TraceForgetColdPeers targetKnown actualKnown sp) = + mconcat [ "kind" .= String "ForgetColdPeers" + , "targetKnown" .= targetKnown + , "actualKnown" .= actualKnown + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TraceBigLedgerPeersRequest tRootPeers nRootPeers) = + mconcat [ "kind" .= String "BigLedgerPeersRequest" + , "targetNumberOfBigLedgerPeers" .= tRootPeers + , "numberOfBigLedgerPeers" .= nRootPeers + ] + forMachine _dtal (TraceBigLedgerPeersResults res group dt) = + mconcat [ "kind" .= String "BigLedgerPeersResults" + , "result" .= toJSONList (toList res) + , "group" .= group + , "diffTime" .= dt + ] + forMachine _dtal (TraceBigLedgerPeersFailure err group dt) = + mconcat [ "kind" .= String "BigLedgerPeersFailure" + , "reason" .= show err + , "group" .= group + , "diffTime" .= dt + ] + forMachine _dtal (TraceForgetBigLedgerPeers targetKnown actualKnown sp) = + mconcat [ "kind" .= String "ForgetColdBigLedgerPeers" + , "targetKnown" .= targetKnown + , "actualKnown" .= actualKnown + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TracePeerShareRequests targetKnown actualKnown (PeerSharingAmount numRequested) aps sps) = + mconcat [ "kind" .= String "PeerShareRequests" + , "targetKnown" .= targetKnown + , "actualKnown" .= actualKnown + , "numRequested" .= numRequested + , "availablePeers" .= toJSONList (toList aps) + , "selectedPeers" .= toJSONList (toList sps) + ] + forMachine _dtal (TracePeerShareResults res) = + mconcat [ "kind" .= String "PeerShareResults" + , "result" .= toJSONList (map (first show <$>) res) + ] + forMachine _dtal (TracePeerShareResultsFiltered res) = + mconcat [ "kind" .= String "PeerShareResultsFiltered" + , "result" .= toJSONList res + ] + forMachine _dtal (TracePromoteColdPeers targetKnown actualKnown sp) = + mconcat [ "kind" .= String "PromoteColdPeers" + , "targetEstablished" .= targetKnown + , "actualEstablished" .= actualKnown + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TracePromoteColdLocalPeers tLocalEst sp) = + mconcat [ "kind" .= String "PromoteColdLocalPeers" + , "targetLocalEstablished" .= tLocalEst + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TracePromoteColdFailed tEst aEst p d err) = + mconcat [ "kind" .= String "PromoteColdFailed" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "peer" .= toJSON p + , "delay" .= toJSON d + , "reason" .= show err + ] + forMachine _dtal (TracePromoteColdDone tEst aEst p) = + mconcat [ "kind" .= String "PromoteColdDone" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "peer" .= toJSON p + ] + forMachine _dtal (TracePromoteColdBigLedgerPeers targetKnown actualKnown sp) = + mconcat [ "kind" .= String "PromoteColdBigLedgerPeers" + , "targetEstablished" .= targetKnown + , "actualEstablished" .= actualKnown + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TracePromoteColdBigLedgerPeerFailed tEst aEst p d err) = + mconcat [ "kind" .= String "PromoteColdBigLedgerPeerFailed" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "peer" .= toJSON p + , "delay" .= toJSON d + , "reason" .= show err + ] + forMachine _dtal (TracePromoteColdBigLedgerPeerDone tEst aEst p) = + mconcat [ "kind" .= String "PromoteColdBigLedgerPeerDone" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "peer" .= toJSON p + ] + forMachine _dtal (TracePromoteWarmPeers tActive aActive sp) = + mconcat [ "kind" .= String "PromoteWarmPeers" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TracePromoteWarmLocalPeers taa sp) = + mconcat [ "kind" .= String "PromoteWarmLocalPeers" + , "targetActualActive" .= toJSONList taa + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TracePromoteWarmFailed tActive aActive p err) = + mconcat [ "kind" .= String "PromoteWarmFailed" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + , "reason" .= show err + ] + forMachine _dtal (TracePromoteWarmDone tActive aActive p) = + mconcat [ "kind" .= String "PromoteWarmDone" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + ] + forMachine _dtal (TracePromoteWarmAborted tActive aActive p) = + mconcat [ "kind" .= String "PromoteWarmAborted" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + ] + forMachine _dtal (TracePromoteWarmBigLedgerPeers tActive aActive sp) = + mconcat [ "kind" .= String "PromoteWarmBigLedgerPeers" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TracePromoteWarmBigLedgerPeerFailed tActive aActive p err) = + mconcat [ "kind" .= String "PromoteWarmBigLedgerPeerFailed" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + , "reason" .= show err + ] + forMachine _dtal (TracePromoteWarmBigLedgerPeerDone tActive aActive p) = + mconcat [ "kind" .= String "PromoteWarmBigLedgerPeerDone" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + ] + forMachine _dtal (TracePromoteWarmBigLedgerPeerAborted tActive aActive p) = + mconcat [ "kind" .= String "PromoteWarmBigLedgerPeerAborted" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + ] + forMachine _dtal (TraceDemoteWarmPeers tEst aEst sp) = + mconcat [ "kind" .= String "DemoteWarmPeers" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TraceDemoteWarmFailed tEst aEst p err) = + mconcat [ "kind" .= String "DemoteWarmFailed" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "peer" .= toJSON p + , "reason" .= show err + ] + forMachine _dtal (TraceDemoteWarmDone tEst aEst p) = + mconcat [ "kind" .= String "DemoteWarmDone" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "peer" .= toJSON p + ] + forMachine _dtal (TraceDemoteWarmBigLedgerPeers tEst aEst sp) = + mconcat [ "kind" .= String "DemoteWarmBigLedgerPeers" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TraceDemoteWarmBigLedgerPeerFailed tEst aEst p err) = + mconcat [ "kind" .= String "DemoteWarmBigLedgerPeerFailed" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "peer" .= toJSON p + , "reason" .= show err + ] + forMachine _dtal (TraceDemoteWarmBigLedgerPeerDone tEst aEst p) = + mconcat [ "kind" .= String "DemoteWarmBigLedgerPeerDone" + , "targetEstablished" .= tEst + , "actualEstablished" .= aEst + , "peer" .= toJSON p + ] + forMachine _dtal (TraceDemoteHotPeers tActive aActive sp) = + mconcat [ "kind" .= String "DemoteHotPeers" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TraceDemoteLocalHotPeers taa sp) = + mconcat [ "kind" .= String "DemoteLocalHotPeers" + , "targetActualActive" .= toJSONList taa + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TraceDemoteHotFailed tActive aActive p err) = + mconcat [ "kind" .= String "DemoteHotFailed" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + , "reason" .= show err + ] + forMachine _dtal (TraceDemoteHotDone tActive aActive p) = + mconcat [ "kind" .= String "DemoteHotDone" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + ] + forMachine _dtal (TraceDemoteHotBigLedgerPeers tActive aActive sp) = + mconcat [ "kind" .= String "DemoteHotBigLedgerPeers" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "selectedPeers" .= toJSONList (toList sp) + ] + forMachine _dtal (TraceDemoteHotBigLedgerPeerFailed tActive aActive p err) = + mconcat [ "kind" .= String "DemoteHotBigLedgerPeerFailed" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + , "reason" .= show err + ] + forMachine _dtal (TraceDemoteHotBigLedgerPeerDone tActive aActive p) = + mconcat [ "kind" .= String "DemoteHotBigLedgerPeerDone" + , "targetActive" .= tActive + , "actualActive" .= aActive + , "peer" .= toJSON p + ] + forMachine _dtal (TraceDemoteAsynchronous msp) = + mconcat [ "kind" .= String "DemoteAsynchronous" + , "state" .= toJSON msp + ] + forMachine _dtal (TraceDemoteLocalAsynchronous msp) = + mconcat [ "kind" .= String "DemoteLocalAsynchronous" + , "state" .= toJSON msp + ] + forMachine _dtal (TraceDemoteBigLedgerPeersAsynchronous msp) = + mconcat [ "kind" .= String "DemoteBigLedgerPeerAsynchronous" + , "state" .= toJSON msp + ] + forMachine _dtal TraceGovernorWakeup = + mconcat [ "kind" .= String "GovernorWakeup" + ] + forMachine _dtal (TraceChurnWait dt) = + mconcat [ "kind" .= String "ChurnWait" + , "diffTime" .= toJSON dt + ] + forMachine _dtal (TracePickInboundPeers targetNumberOfKnownPeers numberOfKnownPeers selected available) = + mconcat [ "kind" .= String "PickInboundPeers" + , "targetKnown" .= targetNumberOfKnownPeers + , "actualKnown" .= numberOfKnownPeers + , "selected" .= selected + , "available" .= available + ] +{-- TODO: Before "cardano-diffusion" removal: + forMachine _dtal (TraceLedgerStateJudgementChanged new) = + mconcat [ "kind" .= String "LedgerStateJudgementChanged" + , "new" .= show new ] +--} + forMachine _dtal TraceOnlyBootstrapPeers = + mconcat [ "kind" .= String "LedgerStateJudgementChanged" ] +{-- TODO: Before "cardano-diffusion" removal: + forMachine _dtal (TraceUseBootstrapPeersChanged ubp) = + mconcat [ "kind" .= String "UseBootstrapPeersChanged" + , "useBootstrapPeers" .= toJSON ubp ] +--} + forMachine _dtal TraceBootstrapPeersFlagChangedWhilstInSensitiveState = + mconcat [ "kind" .= String "BootstrapPeersFlagChangedWhilstInSensitiveState" + ] + forMachine _dtal (TraceVerifyPeerSnapshot result) = + mconcat [ "kind" .= String "VerifyPeerSnapshot" + , "result" .= toJSON result ] + forMachine _dtal (TraceOutboundGovernorCriticalFailure err) = + mconcat [ "kind" .= String "OutboundGovernorCriticalFailure" + , "reason" .= show err + ] + forMachine _dtal (TraceChurnAction duration action counter) = + mconcat [ "kind" .= String "ChurnAction" + , "action" .= show action + , "counter" .= counter + , "duration" .= duration + ] + forMachine _dtal (TraceChurnTimeout duration action counter) = + mconcat [ "kind" .= String "ChurnTimeout" + , "action" .= show action + , "counter" .= counter + , "duration" .= duration + ] + forMachine _dtal (TraceDebugState mtime ds) = + mconcat [ "kind" .= String "DebugState" + , "monotonicTime" .= show mtime + , "targets" .= peerSelectionTargetsToObject (dpssTargets ds) + , "localRootPeers" .= dpssLocalRootPeers ds + , "publicRootPeers" .= dpssPublicRootPeers ds + , "knownPeers" .= KnownPeers.allPeers (dpssKnownPeers ds) + , "establishedPeers" .= dpssEstablishedPeers ds + , "activePeers" .= dpssActivePeers ds + , "publicRootBackoffs" .= dpssPublicRootBackoffs ds + , "publicRootRetryTime" .= dpssPublicRootRetryTime ds + , "bigLedgerPeerBackoffs" .= dpssBigLedgerPeerBackoffs ds + , "bigLedgerPeerRetryTime" .= dpssBigLedgerPeerRetryTime ds + , "inProgressBigLedgerPeersReq" .= dpssInProgressBigLedgerPeersReq ds + , "inProgressPeerShareReqs" .= dpssInProgressPeerShareReqs ds + , "inProgressPromoteCold" .= dpssInProgressPromoteCold ds + , "inProgressPromoteWarm" .= dpssInProgressPromoteWarm ds + , "inProgressDemoteWarm" .= dpssInProgressDemoteWarm ds + , "inProgressDemoteHot" .= dpssInProgressDemoteHot ds + , "inProgressDemoteToCold" .= dpssInProgressDemoteToCold ds + , "upstreamyness" .= dpssUpstreamyness ds + , "fetchynessBlocks" .= dpssFetchynessBlocks ds + ] +{-- TODO: + Pattern match(es) are non-exhaustive + In an equation for ‘forMachine’: + Patterns of type ‘DetailLevel’, + ‘TracePeerSelection + extraDebugState + extraFlags + extraPeers + extraTrace + ntnAddr’ not matched: + _ (ExtraTrace _) + | +107 | forMachine _dtal (TraceLocalRootPeersChanged lrp lrp') = +--} + forMachine _ _ = mempty + forHuman = pack . show + + asMetrics (TraceChurnAction duration action _) = + [ DoubleM ("peerSelection.churn" <> pack (show action) <> ".duration") + (realToFrac duration) + ] + asMetrics _ = [] + +instance MetaTrace (TracePeerSelection extraDebugState extraFlags extraPeers extraTrace SockAddr) where + namespaceFor TraceLocalRootPeersChanged {} = + Namespace [] ["LocalRootPeersChanged"] + namespaceFor TraceTargetsChanged {} = + Namespace [] ["TargetsChanged"] + namespaceFor TracePublicRootsRequest {} = + Namespace [] ["PublicRootsRequest"] + namespaceFor TracePublicRootsResults {} = + Namespace [] ["PublicRootsResults"] + namespaceFor TracePublicRootsFailure {} = + Namespace [] ["PublicRootsFailure"] + namespaceFor TraceForgetColdPeers {} = + Namespace [] ["ForgetColdPeers"] + namespaceFor TraceBigLedgerPeersRequest {} = + Namespace [] ["BigLedgerPeersRequest"] + namespaceFor TraceBigLedgerPeersResults {} = + Namespace [] ["BigLedgerPeersResults"] + namespaceFor TraceBigLedgerPeersFailure {} = + Namespace [] ["BigLedgerPeersFailure"] + namespaceFor TraceForgetBigLedgerPeers {} = + Namespace [] ["ForgetBigLedgerPeers"] + namespaceFor TracePeerShareRequests {} = + Namespace [] ["PeerShareRequests"] + namespaceFor TracePeerShareResults {} = + Namespace [] ["PeerShareResults"] + namespaceFor TracePeerShareResultsFiltered {} = + Namespace [] ["PeerShareResultsFiltered"] + namespaceFor TracePickInboundPeers {} = + Namespace [] ["PickInboundPeers"] + namespaceFor TracePromoteColdPeers {} = + Namespace [] ["PromoteColdPeers"] + namespaceFor TracePromoteColdLocalPeers {} = + Namespace [] ["PromoteColdLocalPeers"] + namespaceFor TracePromoteColdFailed {} = + Namespace [] ["PromoteColdFailed"] + namespaceFor TracePromoteColdDone {} = + Namespace [] ["PromoteColdDone"] + namespaceFor TracePromoteColdBigLedgerPeers {} = + Namespace [] ["PromoteColdBigLedgerPeers"] + namespaceFor TracePromoteColdBigLedgerPeerFailed {} = + Namespace [] ["PromoteColdBigLedgerPeerFailed"] + namespaceFor TracePromoteColdBigLedgerPeerDone {} = + Namespace [] ["PromoteColdBigLedgerPeerDone"] + namespaceFor TracePromoteWarmPeers {} = + Namespace [] ["PromoteWarmPeers"] + namespaceFor TracePromoteWarmLocalPeers {} = + Namespace [] ["PromoteWarmLocalPeers"] + namespaceFor TracePromoteWarmFailed {} = + Namespace [] ["PromoteWarmFailed"] + namespaceFor TracePromoteWarmDone {} = + Namespace [] ["PromoteWarmDone"] + namespaceFor TracePromoteWarmAborted {} = + Namespace [] ["PromoteWarmAborted"] + namespaceFor TracePromoteWarmBigLedgerPeers {} = + Namespace [] ["PromoteWarmBigLedgerPeers"] + namespaceFor TracePromoteWarmBigLedgerPeerFailed {} = + Namespace [] ["PromoteWarmBigLedgerPeerFailed"] + namespaceFor TracePromoteWarmBigLedgerPeerDone {} = + Namespace [] ["PromoteWarmBigLedgerPeerDone"] + namespaceFor TracePromoteWarmBigLedgerPeerAborted {} = + Namespace [] ["PromoteWarmBigLedgerPeerAborted"] + namespaceFor TraceDemoteWarmPeers {} = + Namespace [] ["DemoteWarmPeers"] + namespaceFor (TraceDemoteWarmFailed _ _ _ e) = + case fromException e :: Maybe DemotionTimeoutException of + Just _ -> Namespace [] ["DemoteWarmFailed", "CoolingToColdTimeout"] + Nothing -> Namespace [] ["DemoteWarmFailed"] + namespaceFor TraceDemoteWarmDone {} = + Namespace [] ["DemoteWarmDone"] + namespaceFor TraceDemoteWarmBigLedgerPeers {} = + Namespace [] ["DemoteWarmBigLedgerPeers"] + namespaceFor (TraceDemoteWarmBigLedgerPeerFailed _ _ _ e) = + case fromException e :: Maybe DemotionTimeoutException of + Just _ -> Namespace [] ["DemoteWarmBigLedgerPeerFailed", "CoolingToColdTimeout"] + Nothing -> Namespace [] ["DemoteWarmBigLedgerPeerFailed"] + namespaceFor TraceDemoteWarmBigLedgerPeerDone {} = + Namespace [] ["DemoteWarmBigLedgerPeerDone"] + namespaceFor TraceDemoteHotPeers {} = + Namespace [] ["DemoteHotPeers"] + namespaceFor TraceDemoteLocalHotPeers {} = + Namespace [] ["DemoteLocalHotPeers"] + namespaceFor (TraceDemoteHotFailed _ _ _ e) = + case fromException e :: Maybe DemotionTimeoutException of + Just _ -> Namespace [] ["DemoteHotFailed", "CoolingToColdTimeout"] + Nothing -> Namespace [] ["DemoteHotFailed"] + namespaceFor TraceDemoteHotDone {} = + Namespace [] ["DemoteHotDone"] + namespaceFor TraceDemoteHotBigLedgerPeers {} = + Namespace [] ["DemoteHotBigLedgerPeers"] + namespaceFor (TraceDemoteHotBigLedgerPeerFailed _ _ _ e) = + case fromException e :: Maybe DemotionTimeoutException of + Just _ -> Namespace [] ["DemoteHotBigLedgerPeerFailed", "CoolingToColdTimeout"] + Nothing -> Namespace [] ["DemoteHotBigLedgerPeerFailed"] + namespaceFor TraceDemoteHotBigLedgerPeerDone {} = + Namespace [] ["DemoteHotBigLedgerPeerDone"] + namespaceFor TraceDemoteAsynchronous {} = + Namespace [] ["DemoteAsynchronous"] + namespaceFor TraceDemoteLocalAsynchronous {} = + Namespace [] ["DemoteLocalAsynchronous"] + namespaceFor TraceDemoteBigLedgerPeersAsynchronous {} = + Namespace [] ["DemoteBigLedgerPeersAsynchronous"] + namespaceFor TraceGovernorWakeup {} = + Namespace [] ["GovernorWakeup"] + namespaceFor TraceChurnWait {} = + Namespace [] ["ChurnWait"] +{-- TODO: Before "cardano-diffusion" removal: + namespaceFor TraceLedgerStateJudgementChanged {} = + Namespace [] ["LedgerStateJudgementChanged"] +--} + namespaceFor TraceOnlyBootstrapPeers {} = + Namespace [] ["OnlyBootstrapPeers"] +{-- TODO: Before "cardano-diffusion" removal: + namespaceFor TraceUseBootstrapPeersChanged {} = + Namespace [] ["UseBootstrapPeersChanged"] +--} + namespaceFor TraceVerifyPeerSnapshot {} = + Namespace [] ["VerifyPeerSnapshot"] + namespaceFor TraceBootstrapPeersFlagChangedWhilstInSensitiveState = + Namespace [] ["BootstrapPeersFlagChangedWhilstInSensitiveState"] + namespaceFor TraceOutboundGovernorCriticalFailure {} = + Namespace [] ["OutboundGovernorCriticalFailure"] + namespaceFor TraceChurnAction {} = + Namespace [] ["ChurnAction"] + namespaceFor TraceChurnTimeout {} = + Namespace [] ["ChurnTimeout"] + namespaceFor TraceDebugState {} = + Namespace [] ["DebugState"] +{-- TODO: + > Pattern match(es) are non-exhaustive + > In an equation for ‘namespaceFor’: + > Patterns of type ‘TracePeerSelection + > extraDebugState + > extraFlags + > extraPeers + > extraTrace + > SockAddr’ not matched: + > ExtraTrace _ + > | + > 467 | namespaceFor TraceLocalRootPeersChanged {} = +--} + namespaceFor _ = + Namespace [] [] + + severityFor (Namespace [] ["LocalRootPeersChanged"]) _ = Just Notice + severityFor (Namespace [] ["TargetsChanged"]) _ = Just Notice + severityFor (Namespace [] ["PublicRootsRequest"]) _ = Just Info + severityFor (Namespace [] ["PublicRootsResults"]) _ = Just Info + severityFor (Namespace [] ["PublicRootsFailure"]) _ = Just Error + severityFor (Namespace [] ["ForgetColdPeers"]) _ = Just Info + severityFor (Namespace [] ["BigLedgerPeersRequest"]) _ = Just Info + severityFor (Namespace [] ["BigLedgerPeersResults"]) _ = Just Info + severityFor (Namespace [] ["BigLedgerPeersFailure"]) _ = Just Info + severityFor (Namespace [] ["ForgetBigLedgerPeers"]) _ = Just Info + severityFor (Namespace [] ["PeerShareRequests"]) _ = Just Debug + severityFor (Namespace [] ["PeerShareResults"]) _ = Just Debug + severityFor (Namespace [] ["PeerShareResultsFiltered"]) _ = Just Info + severityFor (Namespace [] ["PickInboundPeers"]) _ = Just Info + severityFor (Namespace [] ["PromoteColdPeers"]) _ = Just Info + severityFor (Namespace [] ["PromoteColdLocalPeers"]) _ = Just Info + severityFor (Namespace [] ["PromoteColdFailed"]) _ = Just Info + severityFor (Namespace [] ["PromoteColdDone"]) _ = Just Info + severityFor (Namespace [] ["PromoteColdBigLedgerPeers"]) _ = Just Info + severityFor (Namespace [] ["PromoteColdBigLedgerPeerFailed"]) _ = Just Info + severityFor (Namespace [] ["PromoteColdBigLedgerPeerDone"]) _ = Just Info + severityFor (Namespace [] ["PromoteWarmPeers"]) _ = Just Info + severityFor (Namespace [] ["PromoteWarmLocalPeers"]) _ = Just Info + severityFor (Namespace [] ["PromoteWarmFailed"]) _ = Just Info + severityFor (Namespace [] ["PromoteWarmDone"]) _ = Just Info + severityFor (Namespace [] ["PromoteWarmAborted"]) _ = Just Info + severityFor (Namespace [] ["PromoteWarmBigLedgerPeers"]) _ = Just Info + severityFor (Namespace [] ["PromoteWarmBigLedgerPeerFailed"]) _ = Just Info + severityFor (Namespace [] ["PromoteWarmBigLedgerPeerDone"]) _ = Just Info + severityFor (Namespace [] ["PromoteWarmBigLedgerPeerAborted"]) _ = Just Info + severityFor (Namespace [] ["DemoteWarmPeers"]) _ = Just Info + severityFor (Namespace [] ["DemoteWarmFailed"]) _ = Just Info + severityFor (Namespace [] ["DemoteWarmFailed", "CoolingToColdTimeout"]) _ = Just Error + severityFor (Namespace [] ["DemoteWarmDone"]) _ = Just Info + severityFor (Namespace [] ["DemoteWarmBigLedgerPeers"]) _ = Just Info + severityFor (Namespace [] ["DemoteWarmBigLedgerPeerFailed"]) _ = Just Info + severityFor (Namespace [] ["DemoteWarmBigLedgerPeerFailed", "CoolingToColdTimeout"]) _ = Just Error + severityFor (Namespace [] ["DemoteWarmBigLedgerPeerDone"]) _ = Just Info + severityFor (Namespace [] ["DemoteHotPeers"]) _ = Just Info + severityFor (Namespace [] ["DemoteLocalHotPeers"]) _ = Just Info + severityFor (Namespace [] ["DemoteHotFailed"]) _ = Just Info + severityFor (Namespace [] ["DemoteHotFailed", "CoolingToColdTimeout"]) _ = Just Error + severityFor (Namespace [] ["DemoteHotDone"]) _ = Just Info + severityFor (Namespace [] ["DemoteHotBigLedgerPeers"]) _ = Just Info + severityFor (Namespace [] ["DemoteHotBigLedgerPeerFailed"]) _ = Just Info + severityFor (Namespace [] ["DemoteHotBigLedgerPeerFailed", "CoolingToColdTimeout"]) _ = Just Error + severityFor (Namespace [] ["DemoteHotBigLedgerPeerDone"]) _ = Just Info + severityFor (Namespace [] ["DemoteAsynchronous"]) _ = Just Info + severityFor (Namespace [] ["DemoteLocalAsynchronous"]) _ = Just Warning + severityFor (Namespace [] ["DemoteBigLedgerPeersAsynchronous"]) _ = Just Info + severityFor (Namespace [] ["GovernorWakeup"]) _ = Just Info + severityFor (Namespace [] ["ChurnWait"]) _ = Just Info + severityFor (Namespace [] ["LedgerStateJudgementChanged"]) _ = Just Info + severityFor (Namespace [] ["OnlyBootstrapPeers"]) _ = Just Info + severityFor (Namespace [] ["UseBootstrapPeersChanged"]) _ = Just Notice + severityFor (Namespace [] ["VerifyPeerSnapshot"]) _ = Just Error + severityFor (Namespace [] ["BootstrapPeersFlagChangedWhilstInSensitiveState"]) _ = Just Warning + severityFor (Namespace [] ["OutboundGovernorCriticalFailure"]) _ = Just Error + severityFor (Namespace [] ["ChurnAction"]) _ = Just Info + severityFor (Namespace [] ["ChurnTimeout"]) _ = Just Notice + severityFor (Namespace [] ["DebugState"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace [] ["LocalRootPeersChanged"]) = Just "" + documentFor (Namespace [] ["TargetsChanged"]) = Just "" + documentFor (Namespace [] ["PublicRootsRequest"]) = Just "" + documentFor (Namespace [] ["PublicRootsResults"]) = Just "" + documentFor (Namespace [] ["PublicRootsFailure"]) = Just "" + documentFor (Namespace [] ["PeerShareRequests"]) = Just $ mconcat + [ "target known peers, actual known peers, peers available for gossip," + , " peers selected for gossip" + ] + documentFor (Namespace [] ["PeerShareResults"]) = Just "" + documentFor (Namespace [] ["ForgetColdPeers"]) = Just + "target known peers, actual known peers, selected peers" + documentFor (Namespace [] ["PromoteColdPeers"]) = Just + "target established, actual established, selected peers" + documentFor (Namespace [] ["PromoteColdLocalPeers"]) = Just + "target local established, actual local established, selected peers" + documentFor (Namespace [] ["PromoteColdFailed"]) = Just $ mconcat + [ "target established, actual established, peer, delay until next" + , " promotion, reason" + ] + documentFor (Namespace [] ["PromoteColdDone"]) = Just + "target active, actual active, selected peers" + documentFor (Namespace [] ["PromoteWarmPeers"]) = Just + "target active, actual active, selected peers" + documentFor (Namespace [] ["PromoteWarmLocalPeers"]) = Just + "local per-group (target active, actual active), selected peers" + documentFor (Namespace [] ["PromoteWarmFailed"]) = Just + "target active, actual active, peer, reason" + documentFor (Namespace [] ["PromoteWarmDone"]) = Just + "target active, actual active, peer" + documentFor (Namespace [] ["PromoteWarmAborted"]) = Just "" + documentFor (Namespace [] ["DemoteWarmPeers"]) = Just + "target established, actual established, selected peers" + documentFor (Namespace [] ["DemoteWarmFailed"]) = Just + "target established, actual established, peer, reason" + documentFor (Namespace [] ["DemoteWarmFailed", "CoolingToColdTimeout"]) = + Just "Impossible asynchronous demotion timeout" + documentFor (Namespace [] ["DemoteWarmBigLedgerPeerFailed", "CoolingToColdTimeout"]) = + Just "Impossible asynchronous demotion timeout" + documentFor (Namespace [] ["DemoteWarmDone"]) = Just + "target established, actual established, peer" + documentFor (Namespace [] ["DemoteHotPeers"]) = Just + "target active, actual active, selected peers" + documentFor (Namespace [] ["DemoteLocalHotPeers"]) = Just + "local per-group (target active, actual active), selected peers" + documentFor (Namespace [] ["DemoteHotFailed"]) = Just + "target active, actual active, peer, reason" + documentFor (Namespace [] ["DemoteHotFailed", "CoolingToColdTimeout"]) = + Just "Impossible asynchronous demotion timeout" + documentFor (Namespace [] ["DemoteHotBigLedgerPeerFailed", "CoolingToColdTimeout"]) = + Just "Impossible asynchronous demotion timeout" + documentFor (Namespace [] ["DemoteHotDone"]) = Just + "target active, actual active, peer" + documentFor (Namespace [] ["DemoteAsynchronous"]) = Just "" + documentFor (Namespace [] ["DemoteLocalAsynchronous"]) = Just "" + documentFor (Namespace [] ["GovernorWakeup"]) = Just "" + documentFor (Namespace [] ["ChurnWait"]) = Just "" + documentFor (Namespace [] ["PickInboundPeers"]) = Just + "An inbound connection was added to known set of outbound governor" + documentFor (Namespace [] ["OutboundGovernorCriticalFailure"]) = Just + "Outbound Governor was killed unexpectedly" + documentFor (Namespace [] ["DebugState"]) = Just + "peer selection internal state" + documentFor (Namespace [] ["VerifyPeerSnapshot"]) = Just + "Verification outcome of big ledger peer snapshot" + documentFor _ = Nothing + + metricsDocFor (Namespace [] ["ChurnAction"]) = + [ ("peerSelection.churn.DecreasedActivePeers.duration", "") + , ("peerSelection.churn.DecreasedActiveBigLedgerPeers.duration", "") + , ("peerSelection.churn.DecreasedEstablishedPeers.duration", "") + , ("peerSelection.churn.DecreasedEstablishedBigLedgerPeers.duration", "") + , ("peerSelection.churn.DecreasedKnownPeers.duration", "") + , ("peerSelection.churn.DecreasedKnownBigLedgerPeers.duration", "") + ] + metricsDocFor _ = [] + + allNamespaces = [ + Namespace [] ["LocalRootPeersChanged"] + , Namespace [] ["TargetsChanged"] + , Namespace [] ["PublicRootsRequest"] + , Namespace [] ["PublicRootsResults"] + , Namespace [] ["PublicRootsFailure"] + , Namespace [] ["ForgetColdPeers"] + , Namespace [] ["BigLedgerPeersRequest"] + , Namespace [] ["BigLedgerPeersResults"] + , Namespace [] ["BigLedgerPeersFailure"] + , Namespace [] ["ForgetBigLedgerPeers"] + , Namespace [] ["PeerShareRequests"] + , Namespace [] ["PeerShareResults"] + , Namespace [] ["PeerShareResultsFiltered"] + , Namespace [] ["PickInboundPeers"] + , Namespace [] ["PromoteColdPeers"] + , Namespace [] ["PromoteColdLocalPeers"] + , Namespace [] ["PromoteColdFailed"] + , Namespace [] ["PromoteColdDone"] + , Namespace [] ["PromoteColdBigLedgerPeers"] + , Namespace [] ["PromoteColdBigLedgerPeerFailed"] + , Namespace [] ["PromoteColdBigLedgerPeerDone"] + , Namespace [] ["PromoteWarmPeers"] + , Namespace [] ["PromoteWarmLocalPeers"] + , Namespace [] ["PromoteWarmFailed"] + , Namespace [] ["PromoteWarmDone"] + , Namespace [] ["PromoteWarmAborted"] + , Namespace [] ["PromoteWarmBigLedgerPeers"] + , Namespace [] ["PromoteWarmBigLedgerPeerFailed"] + , Namespace [] ["PromoteWarmBigLedgerPeerDone"] + , Namespace [] ["PromoteWarmBigLedgerPeerAborted"] + , Namespace [] ["DemoteWarmPeers"] + , Namespace [] ["DemoteWarmFailed"] + , Namespace [] ["DemoteWarmFailed", "CoolingToColdTimeout"] + , Namespace [] ["DemoteWarmDone"] + , Namespace [] ["DemoteWarmBigLedgerPeers"] + , Namespace [] ["DemoteWarmBigLedgerPeerFailed"] + , Namespace [] ["DemoteWarmBigLedgerPeerFailed", "CoolingToColdTimeout"] + , Namespace [] ["DemoteWarmBigLedgerPeerDone"] + , Namespace [] ["DemoteHotPeers"] + , Namespace [] ["DemoteLocalHotPeers"] + , Namespace [] ["DemoteHotFailed"] + , Namespace [] ["DemoteHotFailed", "CoolingToColdTimeout"] + , Namespace [] ["DemoteHotDone"] + , Namespace [] ["DemoteHotBigLedgerPeers"] + , Namespace [] ["DemoteHotBigLedgerPeerFailed"] + , Namespace [] ["DemoteHotBigLedgerPeerFailed", "CoolingToColdTimeout"] + , Namespace [] ["DemoteHotBigLedgerPeerDone"] + , Namespace [] ["DemoteAsynchronous"] + , Namespace [] ["DemoteLocalAsynchronous"] + , Namespace [] ["DemoteBigLedgerPeersAsynchronous"] + , Namespace [] ["GovernorWakeup"] + , Namespace [] ["ChurnWait"] + , Namespace [] ["ChurnAction"] + , Namespace [] ["ChurnTimeout"] + , Namespace [] ["LedgerStateJudgementChanged"] + , Namespace [] ["OnlyBootstrapPeers"] + , Namespace [] ["BootstrapPeersFlagChangedWhilstInSensitiveState"] + , Namespace [] ["UseBootstrapPeersChanged"] + , Namespace [] ["VerifyPeerSnapshot"] + , Namespace [] ["OutboundGovernorCriticalFailure"] + , Namespace [] ["DebugState"] + ] + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/Utils.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/Utils.hs new file mode 100644 index 0000000000..470e23d616 --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/Governor/Utils.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.Governor.Utils + ( peerSelectionTargetsToObject + ) + where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (Value (Object), (.=)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +-- Needed for `ToJSON Network.Socket.Types.PortNumber` +import qualified "ouroboros-network" -- "ouroboros-network:orphan-instances" + Ouroboros.Network.OrphanInstances () +import "ouroboros-network" -- "ouroboros-network:ouroboros-network" + Ouroboros.Network.PeerSelection.Governor.Types + ( PeerSelectionTargets (..) + ) + +-------------------------------------------------------------------------------- + +peerSelectionTargetsToObject :: PeerSelectionTargets -> Value +peerSelectionTargetsToObject + PeerSelectionTargets { targetNumberOfRootPeers, + targetNumberOfKnownPeers, + targetNumberOfEstablishedPeers, + targetNumberOfActivePeers, + targetNumberOfKnownBigLedgerPeers, + targetNumberOfEstablishedBigLedgerPeers, + targetNumberOfActiveBigLedgerPeers + } = + Object $ + mconcat [ "roots" .= targetNumberOfRootPeers + , "knownPeers" .= targetNumberOfKnownPeers + , "established" .= targetNumberOfEstablishedPeers + , "active" .= targetNumberOfActivePeers + , "knownBigLedgerPeers" .= targetNumberOfKnownBigLedgerPeers + , "establishedBigLedgerPeers" .= targetNumberOfEstablishedBigLedgerPeers + , "activeBigLedgerPeers" .= targetNumberOfActiveBigLedgerPeers + ] + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/PeerStateActions.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/PeerStateActions.hs new file mode 100644 index 0000000000..9a70bdbc40 --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/PeerStateActions.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.PeerStateActions () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +import Control.Exception (displayException) +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (toJSON, Value (String), (.=)) +----------------------- +-- Package: "network" - +----------------------- +import "network" Network.Socket (SockAddr) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import "ouroboros-network" -- "ouroboros-network:ouroboros-network" + Ouroboros.Network.PeerSelection.PeerStateActions + ( PeerSelectionActionsTrace (..) ) +-- Needed for `instance ToJSON ConnectionId`. +import "ouroboros-network" -- "ouroboros-network:orphan-instances" + Ouroboros.Network.OrphanInstances () +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +-------------------------------------------------------------------------------- +-- PeerSelectionActions Tracer. +-------------------------------------------------------------------------------- + +-- TODO: Write PeerStatusChangeType ToJSON at ouroboros-network +-- For that an export is needed at ouroboros-network +instance Show lAddr => LogFormatting (PeerSelectionActionsTrace SockAddr lAddr) where + forMachine _dtal (PeerStatusChanged ps) = + mconcat [ "kind" .= String "PeerStatusChanged" + , "peerStatusChangeType" .= show ps + ] + forMachine _dtal (PeerStatusChangeFailure ps f) = + mconcat [ "kind" .= String "PeerStatusChangeFailure" + , "peerStatusChangeType" .= show ps + , "reason" .= show f + ] + forMachine _dtal (PeerMonitoringError connId s) = + mconcat [ "kind" .= String "PeerMonitoringError" + , "connectionId" .= toJSON connId + , "reason" .= show s + ] + forMachine _dtal (PeerMonitoringResult connId wf) = + mconcat [ "kind" .= String "PeerMonitoringResult" + , "connectionId" .= toJSON connId + , "withProtocolTemp" .= show wf + ] + forMachine _dtal (AcquireConnectionError exception) = + mconcat [ "kind" .= String "AcquireConnectionError" + , "error" .= displayException exception + ] + forMachine _dtal (PeerHotDuration connId dt) = + mconcat [ "kind" .= String "PeerHotDuration" + , "connectionId" .= toJSON connId + , "time" .= show dt] + forHuman = pack . show + +instance MetaTrace (PeerSelectionActionsTrace SockAddr lAddr) where + namespaceFor PeerStatusChanged {} = Namespace [] ["StatusChanged"] + namespaceFor PeerStatusChangeFailure {} = Namespace [] ["StatusChangeFailure"] + namespaceFor PeerMonitoringError {} = Namespace [] ["MonitoringError"] + namespaceFor PeerMonitoringResult {} = Namespace [] ["MonitoringResult"] + namespaceFor AcquireConnectionError {} = Namespace [] ["ConnectionError"] + namespaceFor PeerHotDuration {} = Namespace [] ["PeerHotDuration"] + + severityFor (Namespace _ ["StatusChanged"]) _ = Just Info + severityFor (Namespace _ ["StatusChangeFailure"]) _ = Just Error + severityFor (Namespace _ ["MonitoringError"]) _ = Just Error + severityFor (Namespace _ ["MonitoringResult"]) _ = Just Debug + severityFor (Namespace _ ["ConnectionError"]) _ = Just Error + severityFor (Namespace _ ["PeerHotDuration"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["StatusChanged"]) = Just + "" + documentFor (Namespace _ ["StatusChangeFailure"]) = Just + "" + documentFor (Namespace _ ["MonitoringError"]) = Just + "" + documentFor (Namespace _ ["MonitoringResult"]) = Just + "" + documentFor (Namespace _ ["ConnectionError"]) = Just + "" + documentFor (Namespace _ ["PeerHotDuration"]) = Just + "Reports how long the outbound connection was in hot state" + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["StatusChanged"] + , Namespace [] ["StatusChangeFailure"] + , Namespace [] ["MonitoringError"] + , Namespace [] ["MonitoringResult"] + , Namespace [] ["ConnectionError"] + , Namespace [] ["PeerHotDuration"] + ] + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/RootPeersDNS/DNSActions.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/RootPeersDNS/DNSActions.hs new file mode 100644 index 0000000000..915dc7832d --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/RootPeersDNS/DNSActions.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.RootPeersDNS.DNSActions () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (ToJSON, toJSON, Value (String), (.=)) +----------------------- +-- Package: "iproute" - +----------------------- +import qualified "iproute" Data.IP as IP +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +-- Needed for `ToJSON Network.Socket.Types.PortNumber` +import qualified "ouroboros-network" -- "ouroboros-network:orphan-instances" + Ouroboros.Network.OrphanInstances () +import "ouroboros-network" -- "ouroboros-newtwork:ouroboros-network" + Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + ( DNSTrace (..) ) +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +------------------------------------------------------------------------------- +-- Types. +------------------------------------------------------------------------------- + +-- From: `Cardano.Tracing.OrphanInstances.Network`. +instance ToJSON IP.IP where + toJSON ip = String (pack . show $ ip) + +-------------------------------------------------------------------------------- +-- DNSTrace Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting DNSTrace where + forMachine _dtal (DNSLookupResult peerKind domain Nothing results) = + mconcat [ "kind" .= String "DNSLookupResult" + , "peerKind" .= String (pack . show $ peerKind) + , "domain" .= String (pack . show $ domain) + , "results" .= results + ] + forMachine _dtal (DNSLookupResult peerKind domain (Just srv) results) = + mconcat [ "kind" .= String "DNSLookupResult" + , "peerKind" .= String (pack . show $ peerKind) + , "domain" .= String (pack . show $ domain) + , "srv" .= String (pack . show $ srv) + , "results" .= results + ] + forMachine _dtal (DNSLookupError peerKind lookupType domain dnsError) = + mconcat [ "kind" .= String "DNSLookupError" + , "peerKind" .= String (pack . show $ peerKind) + , "lookupKind" .= String (pack . show $ lookupType) + , "domain" .= String (pack . show $ domain) + , "dnsError" .= String (pack . show $ dnsError) + ] + forMachine _dtal (SRVLookupResult peerKind domain results) = + mconcat [ "kind" .= String "SRVLookupResult" + , "peerKind" .= String (pack . show $ peerKind) + , "domain" .= String (pack . show $ domain) + , "results" .= [ (show a, b, c, d, e) + | (a, b, c, d, e) <- results + ] + ] + forMachine _dtal (SRVLookupError peerKind domain) = + mconcat [ "kind" .= String "SRVLookupError" + , "peerKind" .= String (pack . show $ peerKind) + , "domain" .= String (pack . show $ domain) + ] + +instance MetaTrace DNSTrace where + namespaceFor DNSLookupResult {} = + Namespace [] ["DNSLookupResult"] + namespaceFor DNSLookupError {} = + Namespace [] ["DNSLookupError"] + namespaceFor SRVLookupResult {} = + Namespace [] ["SRVLookupResult"] + namespaceFor SRVLookupError {} = + Namespace [] ["SRVLookupError"] + + severityFor _ (Just DNSLookupResult {}) = Just Info + severityFor _ (Just DNSLookupError {}) = Just Info + severityFor _ (Just SRVLookupResult{}) = Just Info + severityFor _ (Just SRVLookupError{}) = Just Info + severityFor _ Nothing = Nothing + + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["DNSLookupResult"] + , Namespace [] ["DNSLookupError"] + , Namespace [] ["SRVLookupResult"] + , Namespace [] ["SRVLookupError"] + ] + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/RootPeersDNS/LocalRootPeers.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/RootPeersDNS/LocalRootPeers.hs new file mode 100644 index 0000000000..b04e87cfc2 --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/RootPeersDNS/LocalRootPeers.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.RootPeersDNS.LocalRootPeers () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +import Control.Exception (displayException) +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (ToJSON, ToJSONKey, toJSON, Value (String), (.=)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +-- Needed for `ToJSON PeerSelection.State.LocalRootPeers.LocalRootConfig` +import qualified "ouroboros-network" -- "ouroboros-network:orphan-instances" + Ouroboros.Network.OrphanInstances () +import "ouroboros-network" -- "ouroboros-newtwork:ouroboros-newtwork" + Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + ( TraceLocalRootPeers (..) + ) +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +-------------------------------------------------------------------------------- +-- LocalRootPeers Tracer +-------------------------------------------------------------------------------- + +{-- TODO: In `cardano-node` it was, OK????: +instance + ( ToJSONKey ntnAddr + , ToJSON ntnAddr + , ToJSONKey RelayAccessPoint + , Show ntnAddr + ) => LogFormatting (TraceLocalRootPeers PeerTrustable ntnAddr) where +--} + +instance + ( ToJSONKey ntnAddr + , ToJSON ntnAddr + , ToJSON extraFlags + , Show ntnAddr + , Show extraFlags + ) => LogFormatting (TraceLocalRootPeers extraFlags ntnAddr) where + forMachine _dtal (TraceLocalRootDomains groups) = + mconcat [ "kind" .= String "LocalRootDomains" + , "localRootDomains" .= toJSON groups + ] + forMachine _dtal (TraceLocalRootWaiting d dt) = + mconcat [ "kind" .= String "LocalRootWaiting" + , "domainAddress" .= toJSON d + , "diffTime" .= show dt + ] + forMachine _dtal (TraceLocalRootGroups groups) = + mconcat [ "kind" .= String "LocalRootGroups" + , "localRootGroups" .= toJSON groups + ] + forMachine _dtal (TraceLocalRootFailure d exception) = + mconcat [ "kind" .= String "LocalRootFailure" + , "domainAddress" .= toJSON d + , "reason" .= displayException exception + ] + forMachine _dtal (TraceLocalRootError d exception) = + mconcat [ "kind" .= String "LocalRootError" + , "domainAddress" .= String (pack . show $ d) + , "reason" .= displayException exception + ] + forMachine _dtal (TraceLocalRootReconfigured d exception) = + mconcat [ "kind" .= String "LocalRootReconfigured" + , "domainAddress" .= toJSON d + , "reason" .= show exception + ] + forMachine _dtal (TraceLocalRootDNSMap dnsMap) = + mconcat + [ "kind" .= String "TraceLocalRootDNSMap" + , "dnsMap" .= dnsMap + ] + forHuman = pack . show + +instance MetaTrace (TraceLocalRootPeers ntnAddr extraFlags) where + namespaceFor = \case + TraceLocalRootDomains {} -> Namespace [] ["LocalRootDomains"] + TraceLocalRootWaiting {} -> Namespace [] ["LocalRootWaiting"] + TraceLocalRootGroups {} -> Namespace [] ["LocalRootGroups"] + TraceLocalRootFailure {} -> Namespace [] ["LocalRootFailure"] + TraceLocalRootError {} -> Namespace [] ["LocalRootError"] + TraceLocalRootReconfigured {} -> Namespace [] ["LocalRootReconfigured"] + TraceLocalRootDNSMap {} -> Namespace [] ["LocalRootDNSMap"] + + severityFor (Namespace [] ["LocalRootDomains"]) _ = Just Info + severityFor (Namespace [] ["LocalRootWaiting"]) _ = Just Info + severityFor (Namespace [] ["LocalRootGroups"]) _ = Just Info + severityFor (Namespace [] ["LocalRootFailure"]) _ = Just Info + severityFor (Namespace [] ["LocalRootError"]) _ = Just Info + severityFor (Namespace [] ["LocalRootReconfigured"]) _ = Just Info + severityFor (Namespace [] ["LocalRootDNSMap"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace [] ["LocalRootDomains"]) = Just + "" + documentFor (Namespace [] ["LocalRootWaiting"]) = Just + "" + documentFor (Namespace [] ["LocalRootGroups"]) = Just + "" + documentFor (Namespace [] ["LocalRootFailure"]) = Just + "" + documentFor (Namespace [] ["LocalRootError"]) = Just + "" + documentFor (Namespace [] ["LocalRootReconfigured"]) = Just + "" + documentFor (Namespace [] ["LocalRootDNSMap"]) = Just + "" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["LocalRootDomains"] + , Namespace [] ["LocalRootWaiting"] + , Namespace [] ["LocalRootGroups"] + , Namespace [] ["LocalRootFailure"] + , Namespace [] ["LocalRootError"] + , Namespace [] ["LocalRootReconfigured"] + , Namespace [] ["LocalRootDNSMap"] + ] + diff --git a/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/RootPeersDNS/PublicRootPeers.hs b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/RootPeersDNS/PublicRootPeers.hs new file mode 100644 index 0000000000..7ade44b07e --- /dev/null +++ b/ouroboros-network/cardano-logging/Ouroboros/Network/Logging/PeerSelection/RootPeersDNS/PublicRootPeers.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.PeerSelection.RootPeersDNS.PublicRootPeers () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (toJSON, toJSONList, Value (String), (.=)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +-- Needed for `ToJSONKey PeerSelection.RelayAccessPoint.RelayAccessPoint` +import qualified "ouroboros-network" -- "ouroboros-network:orphan-instances" + Ouroboros.Network.OrphanInstances () +import "ouroboros-network" -- "ouroboros-newtwork:ouroboros-newtwork" + Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + ( TracePublicRootPeers (..) + ) +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +-------------------------------------------------------------------------------- +-- PublicRootPeers Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting TracePublicRootPeers where + forMachine _dtal (TracePublicRootRelayAccessPoint relays) = + mconcat [ "kind" .= String "PublicRootRelayAddresses" + , "relayAddresses" .= toJSON relays + ] + forMachine _dtal (TracePublicRootDomains domains) = + mconcat [ "kind" .= String "PublicRootDomains" + , "domainAddresses" .= toJSONList domains + ] + forHuman = pack . show + +instance MetaTrace TracePublicRootPeers where + namespaceFor TracePublicRootRelayAccessPoint {} = Namespace [] ["PublicRootRelayAccessPoint"] + namespaceFor TracePublicRootDomains {} = Namespace [] ["PublicRootDomains"] + + severityFor (Namespace [] ["PublicRootRelayAccessPoint"]) _ = Just Info + severityFor (Namespace [] ["PublicRootDomains"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace [] ["PublicRootRelayAccessPoint"]) = Just + "" + documentFor (Namespace [] ["PublicRootDomains"]) = Just + "" + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["PublicRootRelayAccessPoint"] + , Namespace [] ["PublicRootDomains"] + ] + diff --git a/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework.hs b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework.hs new file mode 100644 index 0000000000..4bea09d5b0 --- /dev/null +++ b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.Diffusion`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.Framework () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (Value (String), (.=)) +----------------------- +-- Package: "iproute" - +----------------------- +import qualified "iproute" Data.IP as IP +----------------------- +-- Package: "network" - +----------------------- +import "network" Network.Socket (SockAddr (..)) +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (Text, pack) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import qualified "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.Protocol.Handshake.Type as HS +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.Snocket + ( LocalAddress (..) + , RemoteAddress + ) +------------------------------- +-- Package: "typed-protocols" - +------------------------------- +import "typed-protocols" Network.TypedProtocol.Codec ( AnyMessage (..) ) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging +--------- +-- Self - +--------- +import Ouroboros.Network.Logging.Framework.ConnectionId () +import Ouroboros.Network.Logging.Framework.ConnectionManager () +import Ouroboros.Network.Logging.Framework.Driver () +import Ouroboros.Network.Logging.Framework.InboundGovernor () +import Ouroboros.Network.Logging.Framework.Server () + +-------------------------------------------------------------------------------- +-- Addresses. +-------------------------------------------------------------------------------- + +-- From `Cardano.Node.Tracing.Tracers.P2P` +-- Branch "ana/10.6-final-integration-mix" + +instance LogFormatting LocalAddress where + forMachine _dtal (LocalAddress path) = + mconcat ["path" .= path] + +instance LogFormatting RemoteAddress where + forMachine _dtal (SockAddrInet port addr) = + let ip = IP.fromHostAddress addr in + mconcat [ "addr" .= show ip + , "port" .= show port + ] + forMachine _dtal (SockAddrInet6 port _ addr _) = + let ip = IP.fromHostAddress6 addr in + mconcat [ "addr" .= show ip + , "port" .= show port + ] + forMachine _dtal (SockAddrUnix path) = + mconcat [ "path" .= show path ] + +-------------------------------------------------------------------------------- +-- Handshake Tracer. +-------------------------------------------------------------------------------- + +-- From `Cardano.Node.Tracing.Tracers.Diffusion` +-- Branch "ana/10.6-final-integration-mix" + +instance (Show term, Show ntcVersion) => + LogFormatting (AnyMessage (HS.Handshake ntcVersion term)) where + forMachine _dtal (AnyMessageAndAgency stok msg) = + mconcat [ "kind" .= String kind + , "msg" .= (String . showT $ msg) + , "agency" .= String (pack $ show stok) + ] + where + kind = case msg of + HS.MsgProposeVersions {} -> "ProposeVersions" + HS.MsgReplyVersions {} -> "ReplyVersions" + HS.MsgQueryReply {} -> "QueryReply" + HS.MsgAcceptVersion {} -> "AcceptVersion" + HS.MsgRefuse {} -> "Refuse" + + forHuman (AnyMessageAndAgency stok msg) = + "Handshake (agency, message) = " <> "(" <> showT stok <> "," <> showT msg <> ")" + +instance MetaTrace (AnyMessage (HS.Handshake a b)) where + namespaceFor (AnyMessage msg) = Namespace [] $ case msg of + HS.MsgProposeVersions {} -> ["ProposeVersions"] + HS.MsgReplyVersions {} -> ["ReplyVersions"] + HS.MsgQueryReply {} -> ["QueryReply"] + HS.MsgAcceptVersion {} -> ["AcceptVersion"] + HS.MsgRefuse {} -> ["Refuse"] + + severityFor (Namespace _ [sym]) _ = case sym of + "ProposeVersions" -> Just Info + "ReplyVersions" -> Just Info + "QueryReply" -> Just Info + "AcceptVersion" -> Just Info + "Refuse" -> Just Info + _otherwise -> Nothing + severityFor _ _ = Nothing + + documentFor (Namespace _ sym) = wrap . mconcat $ case sym of + ["ProposeVersions"] -> + [ "Propose versions together with version parameters. It must be" + , " encoded to a sorted list.." + ] + ["ReplyVersions"] -> + [ "`MsgReplyVersions` received as a response to 'MsgProposeVersions'. It" + , " is not supported to explicitly send this message. It can only be" + , " received as a copy of 'MsgProposeVersions' in a simultaneous open" + , " scenario." + ] + ["QueryReply"] -> + [ "`MsgQueryReply` received as a response to a handshake query in " + , " 'MsgProposeVersions' and lists the supported versions." + ] + ["AcceptVersion"] -> + [ "The remote end decides which version to use and sends chosen version." + , "The server is allowed to modify version parameters." + ] + ["Refuse"] -> ["It refuses to run any version."] + _otherwise -> [] :: [Text] + where + wrap it = case it of + "" -> Nothing + it' -> Just it' + + allNamespaces = [ + Namespace [] ["ProposeVersions"] + , Namespace [] ["ReplyVersions"] + , Namespace [] ["QueryReply"] + , Namespace [] ["AcceptVersion"] + , Namespace [] ["Refuse"] + ] + diff --git a/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/ConnectionId.hs b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/ConnectionId.hs new file mode 100644 index 0000000000..0792292c98 --- /dev/null +++ b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/ConnectionId.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.Consensus`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.Framework.ConnectionId () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (Value (String), (.=)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.ConnectionId (ConnectionId (..)) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +-------------------------------------------------------------------------------- +-- Types instances. +-------------------------------------------------------------------------------- + +instance (LogFormatting adr, Show adr) => LogFormatting (ConnectionId adr) where + forMachine _dtal (ConnectionId local' remote) = + mconcat [ "connectionId" .= String (showT local' + <> " " + <> showT remote) + ] + forHuman (ConnectionId local' remote) = + "ConnectionId " <> showT local' <> " " <> showT remote + diff --git a/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/ConnectionManager.hs b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/ConnectionManager.hs new file mode 100644 index 0000000000..6fdcd931db --- /dev/null +++ b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/ConnectionManager.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.Framework.ConnectionManager () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (ToJSON, toJSON, Value (String), object, (.=)) +import "aeson" Data.Aeson.Types (listValue) +-------------------------- +-- Package: "containers" - +-------------------------- +import qualified "containers" Data.Map.Strict as Map +import qualified "containers" Data.Set as Set +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.ConnectionHandler + ( ConnectionHandlerTrace (..) ) +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.ConnectionId + ( ConnectionId (..) ) +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.ConnectionManager.ConnMap + ( ConnMap (..) ) +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.ConnectionManager.Core as ConnectionManager + ( Trace (..) ) +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.ConnectionManager.Types + ( ConnectionManagerCounters (..) ) +import qualified "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.ConnectionManager.Types as ConnectionManager +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.RethrowPolicy + ( ErrorCommand (..) ) +-- Needed for `instance ToJSON ConnectionManager.AbstractState where`. +import qualified "ouroboros-network" -- "ouroboros-network:orphan-instances" + Ouroboros.Network.OrphanInstances () +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +-------------------------------------------------------------------------------- +-- Connection Manager Tracer. +-------------------------------------------------------------------------------- + +instance (Show addr, Show versionNumber, Show agreedOptions, LogFormatting addr, + ToJSON addr, ToJSON versionNumber, ToJSON agreedOptions) + => LogFormatting (ConnectionManager.Trace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where + forMachine dtal (TrIncludeConnection prov peerAddr) = + mconcat $ reverse + [ "kind" .= String "IncludeConnection" + , "remoteAddress" .= forMachine dtal peerAddr + , "provenance" .= String (pack . show $ prov) + ] + forMachine _dtal (TrReleaseConnection prov connId) = + mconcat $ reverse + [ "kind" .= String "UnregisterConnection" + , "remoteAddress" .= toJSON connId + , "provenance" .= String (pack . show $ prov) + ] + forMachine _dtal (TrConnect (Just localAddress) remoteAddress diffusionMode) = + mconcat + [ "kind" .= String "Connect" + , "connectionId" .= toJSON ConnectionId { localAddress, remoteAddress } + , "diffusionMode" .= toJSON diffusionMode + ] + forMachine dtal (TrConnect Nothing remoteAddress diffusionMode) = + mconcat + [ "kind" .= String "Connect" + , "remoteAddress" .= forMachine dtal remoteAddress + , "diffusionMode" .= toJSON diffusionMode + ] + forMachine _dtal (TrConnectError (Just localAddress) remoteAddress err) = + mconcat + [ "kind" .= String "ConnectError" + , "connectionId" .= toJSON ConnectionId { localAddress, remoteAddress } + , "reason" .= String (pack . show $ err) + ] + forMachine dtal (TrConnectError Nothing remoteAddress err) = + mconcat + [ "kind" .= String "ConnectError" + , "remoteAddress" .= forMachine dtal remoteAddress + , "reason" .= String (pack . show $ err) + ] + forMachine _dtal (TrTerminatingConnection prov connId) = + mconcat + [ "kind" .= String "TerminatingConnection" + , "provenance" .= String (pack . show $ prov) + , "connectionId" .= toJSON connId + ] + forMachine dtal (TrTerminatedConnection prov remoteAddress) = + mconcat + [ "kind" .= String "TerminatedConnection" + , "provenance" .= String (pack . show $ prov) + , "remoteAddress" .= forMachine dtal remoteAddress + ] + forMachine dtal (TrConnectionHandler connId a) = + mconcat + [ "kind" .= String "ConnectionHandler" + , "connectionId" .= toJSON connId + , "connectionHandler" .= forMachine dtal a + ] + forMachine _dtal TrShutdown = + mconcat + [ "kind" .= String "Shutdown" + ] + forMachine dtal (TrConnectionExists prov remoteAddress inState) = + mconcat + [ "kind" .= String "ConnectionExists" + , "provenance" .= String (pack . show $ prov) + , "remoteAddress" .= forMachine dtal remoteAddress + , "state" .= toJSON inState + ] + forMachine _dtal (TrForbiddenConnection connId) = + mconcat + [ "kind" .= String "ForbiddenConnection" + , "connectionId" .= toJSON connId + ] + forMachine _dtal (TrConnectionFailure connId) = + mconcat + [ "kind" .= String "ConnectionFailure" + , "connectionId" .= toJSON connId + ] + forMachine dtal (TrConnectionNotFound prov remoteAddress) = + mconcat + [ "kind" .= String "ConnectionNotFound" + , "remoteAddress" .= forMachine dtal remoteAddress + , "provenance" .= String (pack . show $ prov) + ] + forMachine dtal (TrForbiddenOperation remoteAddress connState) = + mconcat + [ "kind" .= String "ForbiddenOperation" + , "remoteAddress" .= forMachine dtal remoteAddress + , "connectionState" .= toJSON connState + ] + forMachine _dtal (TrPruneConnections pruningSet numberPruned chosenPeers) = + mconcat + [ "kind" .= String "PruneConnections" + , "prunedPeers" .= toJSON pruningSet + , "numberPrunedPeers" .= toJSON numberPruned + , "choiceSet" .= toJSON (toJSON `Set.map` chosenPeers) + ] + forMachine _dtal (TrConnectionCleanup connId) = + mconcat + [ "kind" .= String "ConnectionCleanup" + , "connectionId" .= toJSON connId + ] + forMachine _dtal (TrConnectionTimeWait connId) = + mconcat + [ "kind" .= String "ConnectionTimeWait" + , "connectionId" .= toJSON connId + ] + forMachine _dtal (TrConnectionTimeWaitDone connId) = + mconcat + [ "kind" .= String "ConnectionTimeWaitDone" + , "connectionId" .= toJSON connId + ] + forMachine _dtal (TrConnectionManagerCounters cmCounters) = + mconcat + [ "kind" .= String "ConnectionManagerCounters" + , "state" .= toJSON cmCounters + ] + forMachine _dtal (TrState cmState) = + mconcat + [ "kind" .= String "ConnectionManagerState" + , "state" .= listValue (\(remoteAddr, inner) -> + object + [ "connections" .= + listValue (\(localAddr, connState) -> + object + [ "localAddress" .= localAddr + , "state" .= toJSON connState + ] + ) + (Map.toList inner) + , "remoteAddress" .= toJSON remoteAddr + ] + ) + (Map.toList (getConnMap cmState)) + ] + forMachine _dtal (ConnectionManager.TrUnexpectedlyFalseAssertion info) = + mconcat + [ "kind" .= String "UnexpectedlyFalseAssertion" + , "info" .= String (pack . show $ info) + ] + forHuman = pack . show + asMetrics (TrConnectionManagerCounters ConnectionManagerCounters {..}) = + [ IntM + "connectionManager.fullDuplexConns" + (fromIntegral fullDuplexConns) + , IntM + "connectionManager.duplexConns" + (fromIntegral duplexConns) + , IntM + "connectionManager.unidirectionalConns" + (fromIntegral unidirectionalConns) + , IntM + "connectionManager.inboundConns" + (fromIntegral inboundConns) + , IntM + "connectionManager.outboundConns" + (fromIntegral outboundConns) + ] + asMetrics _ = [] + +instance (Show versionNumber, ToJSON versionNumber, ToJSON agreedOptions) + => LogFormatting (ConnectionHandlerTrace versionNumber agreedOptions) where + forMachine _dtal (TrHandshakeSuccess versionNumber agreedOptions) = + mconcat + [ "kind" .= String "HandshakeSuccess" + , "versionNumber" .= toJSON versionNumber + , "agreedOptions" .= toJSON agreedOptions + ] + forMachine _dtal (TrHandshakeQuery vMap) = + mconcat + [ "kind" .= String "HandshakeQuery" + , "versions" .= toJSON ((\(k,v) -> object [ + "versionNumber" .= k + , "options" .= v + ]) <$> Map.toList vMap) + ] + forMachine _dtal (TrHandshakeClientError err) = + mconcat + [ "kind" .= String "HandshakeClientError" + , "reason" .= toJSON err + ] + forMachine _dtal (TrHandshakeServerError err) = + mconcat + [ "kind" .= String "HandshakeServerError" + , "reason" .= toJSON err + ] + forMachine _dtal (TrConnectionHandlerError e err cerr) = + mconcat + [ "kind" .= String "Error" + , "context" .= show e + , "reason" .= show err + , "command" .= show cerr + ] + +instance MetaTrace (ConnectionManager.Trace addr + (ConnectionHandlerTrace versionNumber agreedOptions)) where + namespaceFor TrIncludeConnection {} = Namespace [] ["IncludeConnection"] + namespaceFor TrReleaseConnection {} = Namespace [] ["UnregisterConnection"] + namespaceFor TrConnect {} = Namespace [] ["Connect"] + namespaceFor TrConnectError {} = Namespace [] ["ConnectError"] + namespaceFor TrTerminatingConnection {} = Namespace [] ["TerminatingConnection"] + namespaceFor TrTerminatedConnection {} = Namespace [] ["TerminatedConnection"] + namespaceFor TrConnectionHandler {} = Namespace [] ["ConnectionHandler"] + namespaceFor TrShutdown {} = Namespace [] ["Shutdown"] + namespaceFor TrConnectionExists {} = Namespace [] ["ConnectionExists"] + namespaceFor TrForbiddenConnection {} = Namespace [] ["ForbiddenConnection"] + namespaceFor TrConnectionFailure {} = Namespace [] ["ConnectionFailure"] + namespaceFor TrConnectionNotFound {} = Namespace [] ["ConnectionNotFound"] + namespaceFor TrForbiddenOperation {} = Namespace [] ["ForbiddenOperation"] + namespaceFor TrPruneConnections {} = Namespace [] ["PruneConnections"] + namespaceFor TrConnectionCleanup {} = Namespace [] ["ConnectionCleanup"] + namespaceFor TrConnectionTimeWait {} = Namespace [] ["ConnectionTimeWait"] + namespaceFor TrConnectionTimeWaitDone {} = Namespace [] ["ConnectionTimeWaitDone"] + namespaceFor TrConnectionManagerCounters {} = Namespace [] ["ConnectionManagerCounters"] + namespaceFor TrState {} = Namespace [] ["State"] + namespaceFor ConnectionManager.TrUnexpectedlyFalseAssertion {} = + Namespace [] ["UnexpectedlyFalseAssertion"] + + severityFor (Namespace _ ["IncludeConnection"]) _ = Just Debug + severityFor (Namespace _ ["UnregisterConnection"]) _ = Just Debug + severityFor (Namespace _ ["Connect"]) _ = Just Debug + severityFor (Namespace _ ["ConnectError"]) _ = Just Info + severityFor (Namespace _ ["TerminatingConnection"]) _ = Just Debug + severityFor (Namespace _ ["TerminatedConnection"]) _ = Just Debug + severityFor (Namespace _ ["ConnectionHandler"]) + (Just (TrConnectionHandler _ ev')) = Just $ + case ev' of + TrHandshakeSuccess {} -> Info + TrHandshakeQuery {} -> Info + TrHandshakeClientError {} -> Notice + TrHandshakeServerError {} -> Info + TrConnectionHandlerError _ _ ShutdownNode -> Critical + TrConnectionHandlerError _ _ ShutdownPeer -> Info + severityFor (Namespace _ ["ConnectionHandler"]) _ = Just Info + severityFor (Namespace _ ["Shutdown"]) _ = Just Info + severityFor (Namespace _ ["ConnectionExists"]) _ = Just Info + severityFor (Namespace _ ["ForbiddenConnection"]) _ = Just Info + severityFor (Namespace _ ["ImpossibleConnection"]) _ = Just Info + severityFor (Namespace _ ["ConnectionFailure"]) _ = Just Info + severityFor (Namespace _ ["ConnectionNotFound"]) _ = Just Debug + severityFor (Namespace _ ["ForbiddenOperation"]) _ = Just Info + severityFor (Namespace _ ["PruneConnections"]) _ = Just Notice + severityFor (Namespace _ ["ConnectionCleanup"]) _ = Just Debug + severityFor (Namespace _ ["ConnectionTimeWait"]) _ = Just Debug + severityFor (Namespace _ ["ConnectionTimeWaitDone"]) _ = Just Info + severityFor (Namespace _ ["ConnectionManagerCounters"]) _ = Just Debug + severityFor (Namespace _ ["State"]) _ = Just Info + severityFor (Namespace _ ["UnexpectedlyFalseAssertion"]) _ = Just Error + severityFor _ _ = Nothing + + documentFor (Namespace _ ["IncludeConnection"]) = Just "" + documentFor (Namespace _ ["UnregisterConnection"]) = Just "" + documentFor (Namespace _ ["Connect"]) = Just "" + documentFor (Namespace _ ["ConnectError"]) = Just "" + documentFor (Namespace _ ["TerminatingConnection"]) = Just "" + documentFor (Namespace _ ["TerminatedConnection"]) = Just "" + documentFor (Namespace _ ["ConnectionHandler"]) = Just "" + documentFor (Namespace _ ["Shutdown"]) = Just "" + documentFor (Namespace _ ["ConnectionExists"]) = Just "" + documentFor (Namespace _ ["ForbiddenConnection"]) = Just "" + documentFor (Namespace _ ["ImpossibleConnection"]) = Just "" + documentFor (Namespace _ ["ConnectionFailure"]) = Just "" + documentFor (Namespace _ ["ConnectionNotFound"]) = Just "" + documentFor (Namespace _ ["ForbiddenOperation"]) = Just "" + documentFor (Namespace _ ["PruneConnections"]) = Just "" + documentFor (Namespace _ ["ConnectionCleanup"]) = Just "" + documentFor (Namespace _ ["ConnectionTimeWait"]) = Just "" + documentFor (Namespace _ ["ConnectionTimeWaitDone"]) = Just "" + documentFor (Namespace _ ["ConnectionManagerCounters"]) = Just "" + documentFor (Namespace _ ["State"]) = Just "" + documentFor (Namespace _ ["UnexpectedlyFalseAssertion"]) = Just "" + documentFor _ = Nothing + + metricsDocFor (Namespace _ ["ConnectionManagerCounters"]) = + [("connectionManager.fullDuplexConns","") + ,("connectionManager.duplexConns","") + ,("connectionManager.unidirectionalConns","") + ,("connectionManager.inboundConns","") + ,("connectionManager.outboundConns","") + ,("connectionManager.prunableConns","") + ] + metricsDocFor _ = [] + + allNamespaces = [ + Namespace [] ["IncludeConnection"] + , Namespace [] ["UnregisterConnection"] + , Namespace [] ["Connect"] + , Namespace [] ["ConnectError"] + , Namespace [] ["TerminatingConnection"] + , Namespace [] ["TerminatedConnection"] + , Namespace [] ["ConnectionHandler"] + , Namespace [] ["Shutdown"] + , Namespace [] ["ConnectionExists"] + , Namespace [] ["ForbiddenConnection"] + , Namespace [] ["ImpossibleConnection"] + , Namespace [] ["ConnectionFailure"] + , Namespace [] ["ConnectionNotFound"] + , Namespace [] ["ForbiddenOperation"] + , Namespace [] ["PruneConnections"] + , Namespace [] ["ConnectionCleanup"] + , Namespace [] ["ConnectionTimeWait"] + , Namespace [] ["ConnectionTimeWaitDone"] + , Namespace [] ["ConnectionManagerCounters"] + , Namespace [] ["State"] + , Namespace [] ["UnexpectedlyFalseAssertion"] + ] + +-------------------------------------------------------------------------------- +-- Connection Manager Transition Tracer. +-------------------------------------------------------------------------------- + +instance (Show peerAddr, ToJSON peerAddr) + => LogFormatting (ConnectionManager.AbstractTransitionTrace peerAddr) where + forMachine _dtal (ConnectionManager.TransitionTrace peerAddr tr) = + mconcat $ reverse + [ "kind" .= String "ConnectionManagerTransition" + , "address" .= toJSON peerAddr + , "from" .= toJSON (ConnectionManager.fromState tr) + , "to" .= toJSON (ConnectionManager.toState tr) + ] + forHuman = pack . show + asMetrics _ = [] + +instance MetaTrace (ConnectionManager.AbstractTransitionTrace peerAddr) where + namespaceFor ConnectionManager.TransitionTrace {} = + Namespace [] ["Transition"] + + severityFor (Namespace _ ["Transition"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["Transition"]) = Just "" + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["Transition"]] + diff --git a/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/Driver.hs b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/Driver.hs new file mode 100644 index 0000000000..09f5b93709 --- /dev/null +++ b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/Driver.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.NodeToClient`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.Framework.Driver () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (Value (String), (.=)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import qualified "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.Driver.Simple as Simple +import qualified "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.Driver.Stateful as Stateful +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging +------------------------------- +-- Package: "typed-protocols" - +------------------------------- +import qualified "typed-protocols" Network.TypedProtocol.Codec as Simple +import qualified "typed-protocols" Network.TypedProtocol.Stateful.Codec as Stateful + +------------------------------------------------------------------------------- +-- Driver Simple. +------------------------------------------------------------------------------- + +instance LogFormatting (Simple.AnyMessage ps) + => LogFormatting (Simple.TraceSendRecv ps) where + forMachine dtal (Simple.TraceSendMsg m) = mconcat + [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] + forMachine dtal (Simple.TraceRecvMsg m) = mconcat + [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ] + + forHuman (Simple.TraceSendMsg m) = "Send: " <> forHumanOrMachine m + forHuman (Simple.TraceRecvMsg m) = "Receive: " <> forHumanOrMachine m + + asMetrics (Simple.TraceSendMsg m) = asMetrics m + asMetrics (Simple.TraceRecvMsg m) = asMetrics m + +instance LogFormatting (Stateful.AnyMessage ps f) + => LogFormatting (Stateful.TraceSendRecv ps f) where + forMachine dtal (Stateful.TraceSendMsg m) = mconcat + [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] + forMachine dtal (Stateful.TraceRecvMsg m) = mconcat + [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ] + + forHuman (Stateful.TraceSendMsg m) = "Send: " <> forHumanOrMachine m + forHuman (Stateful.TraceRecvMsg m) = "Receive: " <> forHumanOrMachine m + + asMetrics (Stateful.TraceSendMsg m) = asMetrics m + asMetrics (Stateful.TraceRecvMsg m) = asMetrics m + +instance MetaTrace (Simple.AnyMessage ps) => + MetaTrace (Simple.TraceSendRecv ps) where + namespaceFor (Simple.TraceSendMsg msg) = + nsPrependInner "Send" (namespaceFor msg) + namespaceFor (Simple.TraceRecvMsg msg) = + nsPrependInner "Receive" (namespaceFor msg) + + severityFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = + severityFor (Namespace out tl) (Just msg) + severityFor (Namespace out ("Send" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + severityFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = + severityFor (Namespace out tl) (Just msg) + severityFor (Namespace out ("Receive" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + severityFor _ _ = Nothing + + privacyFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = + privacyFor (Namespace out tl) (Just msg) + privacyFor (Namespace out ("Send" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + privacyFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = + privacyFor (Namespace out tl) (Just msg) + privacyFor (Namespace out ("Receive" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + privacyFor _ _ = Nothing + + detailsFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = + detailsFor (Namespace out tl) (Just msg) + detailsFor (Namespace out ("Send" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + detailsFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = + detailsFor (Namespace out tl) (Just msg) + detailsFor (Namespace out ("Receive" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing + detailsFor _ _ = Nothing + + metricsDocFor (Namespace out ("Send" : tl)) = + metricsDocFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) + metricsDocFor (Namespace out ("Receive" : tl)) = + metricsDocFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) + metricsDocFor _ = [] + + documentFor (Namespace out ("Send" : tl)) = + documentFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) + documentFor (Namespace out ("Receive" : tl)) = + documentFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) + documentFor _ = Nothing + + allNamespaces = + let cn = allNamespaces :: [Namespace (Simple.AnyMessage ps)] + in fmap (nsPrependInner "Send") cn ++ fmap (nsPrependInner "Receive") cn + +instance MetaTrace (Stateful.AnyMessage ps f) => + MetaTrace (Stateful.TraceSendRecv ps f) where + namespaceFor (Stateful.TraceSendMsg msg) = + nsPrependInner "Send" (namespaceFor msg) + namespaceFor (Stateful.TraceRecvMsg msg) = + nsPrependInner "Receive" (namespaceFor msg) + + severityFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = + severityFor (Namespace out tl) (Just msg) + severityFor (Namespace out ("Send" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing + severityFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = + severityFor (Namespace out tl) (Just msg) + severityFor (Namespace out ("Receive" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing + severityFor _ _ = Nothing + + privacyFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = + privacyFor (Namespace out tl) (Just msg) + privacyFor (Namespace out ("Send" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing + privacyFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = + privacyFor (Namespace out tl) (Just msg) + privacyFor (Namespace out ("Receive" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing + privacyFor _ _ = Nothing + + detailsFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = + detailsFor (Namespace out tl) (Just msg) + detailsFor (Namespace out ("Send" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing + detailsFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = + detailsFor (Namespace out tl) (Just msg) + detailsFor (Namespace out ("Receive" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing + detailsFor _ _ = Nothing + + metricsDocFor (Namespace out ("Send" : tl)) = + metricsDocFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) + metricsDocFor (Namespace out ("Receive" : tl)) = + metricsDocFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) + metricsDocFor _ = [] + + documentFor (Namespace out ("Send" : tl)) = + documentFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) + documentFor (Namespace out ("Receive" : tl)) = + documentFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) + documentFor _ = Nothing + + allNamespaces = + let cn = allNamespaces :: [Namespace (Stateful.AnyMessage ps f)] + in fmap (nsPrependInner "Send") cn ++ fmap (nsPrependInner "Receive") cn diff --git a/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/InboundGovernor.hs b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/InboundGovernor.hs new file mode 100644 index 0000000000..b5fd3c18cb --- /dev/null +++ b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/InboundGovernor.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.Framework.InboundGovernor () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (ToJSON, ToJSONKey, toJSON, Value (String), Object, (.=)) +----------------------- +-- Package: "network" - +----------------------- +import "network" Network.Socket (SockAddr (..)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import qualified "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.ConnectionManager.Types as ConnectionManager +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.InboundGovernor as InboundGovernor (Trace (..)) +import qualified "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.InboundGovernor as InboundGovernor +-- Needed for `ToJSON SockAddr`. +-- Needed for `ToJSON LocalAddress` +-- Needed for `ToJSON (ConnectionId adr)` +-- Needed for `ToJSON MiniProtocolNum` +-- Needed for `ToJSON (ConnectionManager.OperationResult, ConnectionManager.AbstractState)` +-- Needed for `ToJSONKey (ConnectionId adr)` +-- Needed for `ToJSON InboundGovernor.RemoteSt` +import qualified "ouroboros-network" -- "ouroboros-network:orphan-instances" + Ouroboros.Network.OrphanInstances () +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.Snocket (LocalAddress (..)) +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.InboundGovernor.State as InboundGovernor + ( Counters (..) ) +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging + +-------------------------------------------------------------------------------- +-- InboundGovernor Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting (InboundGovernor.Trace SockAddr) where + forMachine = forMachineGov + forHuman = pack . show + asMetrics (TrInboundGovernorCounters InboundGovernor.Counters {..}) = + [ IntM + "inboundGovernor.idle" + (fromIntegral idlePeersRemote) + , IntM + "inboundGovernor.cold" + (fromIntegral coldPeersRemote) + , IntM + "inboundGovernor.warm" + (fromIntegral warmPeersRemote) + , IntM + "inboundGovernor.hot" + (fromIntegral hotPeersRemote) + ] + asMetrics _ = [] + +instance LogFormatting (InboundGovernor.Trace LocalAddress) where + forMachine = forMachineGov + forHuman = pack . show + asMetrics (TrInboundGovernorCounters InboundGovernor.Counters {..}) = + [ IntM + "localInboundGovernor.idle" + (fromIntegral idlePeersRemote) + , IntM + "localInboundGovernor.cold" + (fromIntegral coldPeersRemote) + , IntM + "localInboundGovernor.warm" + (fromIntegral warmPeersRemote) + , IntM + "localInboundGovernor.hot" + (fromIntegral hotPeersRemote) + ] + asMetrics _ = [] + + +forMachineGov :: (ToJSON adr, Show adr, ToJSONKey adr) => DetailLevel -> InboundGovernor.Trace adr -> Object +forMachineGov _dtal (TrNewConnection p connId) = + mconcat [ "kind" .= String "NewConnection" + , "provenance" .= show p + , "connectionId" .= toJSON connId + ] +forMachineGov _dtal (TrResponderRestarted connId m) = + mconcat [ "kind" .= String "ResponderStarted" + , "connectionId" .= toJSON connId + , "miniProtocolNum" .= toJSON m + ] +forMachineGov _dtal (TrResponderStartFailure connId m s) = + mconcat [ "kind" .= String "ResponderStartFailure" + , "connectionId" .= toJSON connId + , "miniProtocolNum" .= toJSON m + , "reason" .= show s + ] +forMachineGov _dtal (TrResponderErrored connId m s) = + mconcat [ "kind" .= String "ResponderErrored" + , "connectionId" .= toJSON connId + , "miniProtocolNum" .= toJSON m + , "reason" .= show s + ] +forMachineGov _dtal (TrResponderStarted connId m) = + mconcat [ "kind" .= String "ResponderStarted" + , "connectionId" .= toJSON connId + , "miniProtocolNum" .= toJSON m + ] +forMachineGov _dtal (TrResponderTerminated connId m) = + mconcat [ "kind" .= String "ResponderTerminated" + , "connectionId" .= toJSON connId + , "miniProtocolNum" .= toJSON m + ] +forMachineGov _dtal (TrPromotedToWarmRemote connId opRes) = + mconcat [ "kind" .= String "PromotedToWarmRemote" + , "connectionId" .= toJSON connId + , "result" .= toJSON opRes + ] +forMachineGov _dtal (TrPromotedToHotRemote connId) = + mconcat [ "kind" .= String "PromotedToHotRemote" + , "connectionId" .= toJSON connId + ] +forMachineGov _dtal (TrDemotedToColdRemote connId od) = + mconcat [ "kind" .= String "DemotedToColdRemote" + , "connectionId" .= toJSON connId + , "result" .= show od + ] +forMachineGov _dtal (TrDemotedToWarmRemote connId) = + mconcat [ "kind" .= String "DemotedToWarmRemote" + , "connectionId" .= toJSON connId + ] +forMachineGov _dtal (TrWaitIdleRemote connId opRes) = + mconcat [ "kind" .= String "WaitIdleRemote" + , "connectionId" .= toJSON connId + , "result" .= toJSON opRes + ] +forMachineGov _dtal (TrMuxCleanExit connId) = + mconcat [ "kind" .= String "MuxCleanExit" + , "connectionId" .= toJSON connId + ] +forMachineGov _dtal (TrMuxErrored connId s) = + mconcat [ "kind" .= String "MuxErrored" + , "connectionId" .= toJSON connId + , "reason" .= show s + ] +forMachineGov _dtal (TrInboundGovernorCounters counters) = + mconcat [ "kind" .= String "InboundGovernorCounters" + , "idlePeers" .= idlePeersRemote counters + , "coldPeers" .= coldPeersRemote counters + , "warmPeers" .= warmPeersRemote counters + , "hotPeers" .= hotPeersRemote counters + ] +forMachineGov _dtal (TrRemoteState st) = + mconcat [ "kind" .= String "RemoteState" + , "remoteSt" .= toJSON st + ] +forMachineGov _dtal (InboundGovernor.TrUnexpectedlyFalseAssertion info) = + mconcat [ "kind" .= String "UnexpectedlyFalseAssertion" + , "remoteSt" .= String (pack . show $ info) + ] +forMachineGov _dtal (InboundGovernor.TrInboundGovernorError err) = + mconcat [ "kind" .= String "InboundGovernorError" + , "remoteSt" .= String (pack . show $ err) + ] +forMachineGov _dtal (InboundGovernor.TrMaturedConnections matured fresh) = + mconcat [ "kind" .= String "MaturedConnections" + , "matured" .= toJSON matured + , "fresh" .= toJSON fresh + ] +forMachineGov _dtal (InboundGovernor.TrInactive fresh) = + mconcat [ "kind" .= String "Inactive" + , "fresh" .= toJSON fresh + ] + +instance MetaTrace (InboundGovernor.Trace addr) where + namespaceFor TrNewConnection {} = Namespace [] ["NewConnection"] + namespaceFor TrResponderRestarted {} = Namespace [] ["ResponderRestarted"] + namespaceFor TrResponderStartFailure {} = Namespace [] ["ResponderStartFailure"] + namespaceFor TrResponderErrored {} = Namespace [] ["ResponderErrored"] + namespaceFor TrResponderStarted {} = Namespace [] ["ResponderStarted"] + namespaceFor TrResponderTerminated {} = Namespace [] ["ResponderTerminated"] + namespaceFor TrPromotedToWarmRemote {} = Namespace [] ["PromotedToWarmRemote"] + namespaceFor TrPromotedToHotRemote {} = Namespace [] ["PromotedToHotRemote"] + namespaceFor TrDemotedToColdRemote {} = Namespace [] ["DemotedToColdRemote"] + namespaceFor TrDemotedToWarmRemote {} = Namespace [] ["DemotedToWarmRemote"] + namespaceFor TrWaitIdleRemote {} = Namespace [] ["WaitIdleRemote"] + namespaceFor TrMuxCleanExit {} = Namespace [] ["MuxCleanExit"] + namespaceFor TrMuxErrored {} = Namespace [] ["MuxErrored"] + namespaceFor TrInboundGovernorCounters {} = Namespace [] ["InboundGovernorCounters"] + namespaceFor TrRemoteState {} = Namespace [] ["RemoteState"] + namespaceFor InboundGovernor.TrUnexpectedlyFalseAssertion {} = + Namespace [] ["UnexpectedlyFalseAssertion"] + namespaceFor InboundGovernor.TrInboundGovernorError {} = + Namespace [] ["InboundGovernorError"] + namespaceFor InboundGovernor.TrMaturedConnections {} = + Namespace [] ["MaturedConnections"] + namespaceFor InboundGovernor.TrInactive {} = + Namespace [] ["Inactive"] + + severityFor (Namespace _ ["NewConnection"]) _ = Just Debug + severityFor (Namespace _ ["ResponderRestarted"]) _ = Just Debug + severityFor (Namespace _ ["ResponderStartFailure"]) _ = Just Info + severityFor (Namespace _ ["ResponderErrored"]) _ = Just Info + severityFor (Namespace _ ["ResponderStarted"]) _ = Just Debug + severityFor (Namespace _ ["ResponderTerminated"]) _ = Just Debug + severityFor (Namespace _ ["PromotedToWarmRemote"]) _ = Just Info + severityFor (Namespace _ ["PromotedToHotRemote"]) _ = Just Info + severityFor (Namespace _ ["DemotedToColdRemote"]) _ = Just Info + severityFor (Namespace _ ["DemotedToWarmRemote"]) _ = Just Info + severityFor (Namespace _ ["WaitIdleRemote"]) _ = Just Debug + severityFor (Namespace _ ["MuxCleanExit"]) _ = Just Debug + severityFor (Namespace _ ["MuxErrored"]) _ = Just Info + severityFor (Namespace _ ["InboundGovernorCounters"]) _ = Just Info + severityFor (Namespace _ ["RemoteState"]) _ = Just Debug + severityFor (Namespace _ ["UnexpectedlyFalseAssertion"]) _ = Just Error + severityFor (Namespace _ ["InboundGovernorError"]) _ = Just Error + severityFor (Namespace _ ["MaturedConnections"]) _ = Just Info + severityFor (Namespace _ ["Inactive"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["NewConnection"]) = Just "" + documentFor (Namespace _ ["ResponderRestarted"]) = Just "" + documentFor (Namespace _ ["ResponderStartFailure"]) = Just "" + documentFor (Namespace _ ["ResponderErrored"]) = Just "" + documentFor (Namespace _ ["ResponderStarted"]) = Just "" + documentFor (Namespace _ ["ResponderTerminated"]) = Just "" + documentFor (Namespace _ ["PromotedToWarmRemote"]) = Just "" + documentFor (Namespace _ ["PromotedToHotRemote"]) = Just "" + documentFor (Namespace _ ["DemotedToColdRemote"]) = Just $ mconcat + [ "All mini-protocols terminated. The boolean is true if this connection" + , " was not used by p2p-governor, and thus the connection will be terminated." + ] + documentFor (Namespace _ ["DemotedToWarmRemote"]) = Just $ mconcat + [ "All mini-protocols terminated. The boolean is true if this connection" + , " was not used by p2p-governor, and thus the connection will be terminated." + ] + documentFor (Namespace _ ["WaitIdleRemote"]) = Just "" + documentFor (Namespace _ ["MuxCleanExit"]) = Just "" + documentFor (Namespace _ ["MuxErrored"]) = Just "" + documentFor (Namespace _ ["InboundGovernorCounters"]) = Just "" + documentFor (Namespace _ ["RemoteState"]) = Just "" + documentFor (Namespace _ ["UnexpectedlyFalseAssertion"]) = Just "" + documentFor (Namespace _ ["InboundGovernorError"]) = Just "" + documentFor (Namespace _ ["MaturedConnections"]) = Just "" + documentFor (Namespace _ ["Inactive"]) = Just "" + documentFor _ = Nothing + + metricsDocFor (Namespace ons ["InboundGovernorCounters"]) + | null ons -- docu generation + = + [("localInboundGovernor.idle","") + ,("localInboundGovernor.cold","") + ,("localInboundGovernor.warm","") + ,("localInboundGovernor.hot","") + ,("inboundGovernor.Idle","") + ,("inboundGovernor.Cold","") + ,("inboundGovernor.Warm","") + ,("inboundGovernor.Hot","") + ] + | last ons == "Local" + = + [("localInboundGovernor.idle","") + ,("localInboundGovernor.cold","") + ,("localInboundGovernor.warm","") + ,("localInboundGovernor.hot","") + ] + | otherwise + = + [("inboundGovernor.Idle","") + ,("inboundGovernor.Cold","") + ,("inboundGovernor.Warm","") + ,("inboundGovernor.Hot","") + ] + metricsDocFor _ = [] + + allNamespaces = [ + Namespace [] ["NewConnection"] + , Namespace [] ["ResponderRestarted"] + , Namespace [] ["ResponderStartFailure"] + , Namespace [] ["ResponderErrored"] + , Namespace [] ["ResponderStarted"] + , Namespace [] ["ResponderTerminated"] + , Namespace [] ["PromotedToWarmRemote"] + , Namespace [] ["PromotedToHotRemote"] + , Namespace [] ["DemotedToColdRemote"] + , Namespace [] ["DemotedToWarmRemote"] + , Namespace [] ["WaitIdleRemote"] + , Namespace [] ["MuxCleanExit"] + , Namespace [] ["MuxErrored"] + , Namespace [] ["InboundGovernorCounters"] + , Namespace [] ["RemoteState"] + , Namespace [] ["UnexpectedlyFalseAssertion"] + , Namespace [] ["InboundGovernorError"] + , Namespace [] ["MaturedConnections"] + , Namespace [] ["Inactive"] + ] + +-------------------------------------------------------------------------------- +-- InboundGovernor Transition Tracer +-------------------------------------------------------------------------------- + + +instance (Show peerAddr, ToJSON peerAddr) + => LogFormatting (InboundGovernor.RemoteTransitionTrace peerAddr) where + forMachine _dtal (InboundGovernor.TransitionTrace peerAddr tr) = + mconcat $ reverse + [ "kind" .= String "ConnectionManagerTransition" + , "address" .= toJSON peerAddr + , "from" .= toJSON (ConnectionManager.fromState tr) + , "to" .= toJSON (ConnectionManager.toState tr) + ] + forHuman = pack . show + asMetrics _ = [] + +instance MetaTrace (InboundGovernor.RemoteTransitionTrace peerAddr) where + namespaceFor InboundGovernor.TransitionTrace {} = Namespace [] ["Transition"] + + severityFor (Namespace [] ["Transition"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace [] ["Transition"]) = Just "" + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["Transition"]] + diff --git a/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/Server.hs b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/Server.hs new file mode 100644 index 0000000000..ca7bdd61e4 --- /dev/null +++ b/ouroboros-network/framework/cardano-logging/Ouroboros/Network/Logging/Framework/Server.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +-------------------------------------------------------------------------------- + +-- Orphan instances module for Cardano tracer. +{-# OPTIONS_GHC -Wno-orphans #-} +-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.P2P`. +-- Branch "ana/10.6-final-integration-mix" + +-------------------------------------------------------------------------------- + +module Ouroboros.Network.Logging.Framework.Server () where + +-------------------------------------------------------------------------------- + +--------- +-- base - +--------- +-- +--------------------- +-- Package: "aeson" - +--------------------- +import "aeson" Data.Aeson (ToJSON, toJSON, Value (String), (.=)) +--------------------------------- +-- Package: "ouroboros-network" - +--------------------------------- +import "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.Server as Server +import qualified "ouroboros-network" -- "ouroboros-newtwork:framework" + Ouroboros.Network.Server.RateLimiting as SRL +-- Needed for `instance ToJSON (ConnectionId addr) where` +import qualified "ouroboros-network" -- "ouroboros-network:orphan-instances" + Ouroboros.Network.OrphanInstances () +-------------------- +-- Package: "text" - +-------------------- +import "text" Data.Text (pack) +-------------------------------- +-- Package: "trace-dispatcher" - +-------------------------------- +import "trace-dispatcher" Cardano.Logging +--------- +-- Self - +--------- +import Ouroboros.Network.Logging.Framework.ConnectionId () + +-------------------------------------------------------------------------------- +-- AcceptPolicy Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting SRL.AcceptConnectionsPolicyTrace where + forMachine _dtal (SRL.ServerTraceAcceptConnectionRateLimiting delay numOfConnections) = + mconcat [ "kind" .= String "ServerTraceAcceptConnectionRateLimiting" + , "delay" .= show delay + , "numberOfConnection" .= show numOfConnections + ] + forMachine _dtal (SRL.ServerTraceAcceptConnectionHardLimit softLimit) = + mconcat [ "kind" .= String "ServerTraceAcceptConnectionHardLimit" + , "softLimit" .= show softLimit + ] + forMachine _dtal (SRL.ServerTraceAcceptConnectionResume numOfConnections) = + mconcat [ "kind" .= String "ServerTraceAcceptConnectionResume" + , "numberOfConnection" .= show numOfConnections + ] + forHuman = showT + +instance MetaTrace SRL.AcceptConnectionsPolicyTrace where + namespaceFor SRL.ServerTraceAcceptConnectionRateLimiting {} = + Namespace [] ["ConnectionRateLimiting"] + namespaceFor SRL.ServerTraceAcceptConnectionHardLimit {} = + Namespace [] ["ConnectionHardLimit"] + namespaceFor SRL.ServerTraceAcceptConnectionResume {} = + Namespace [] ["ConnectionLimitResume"] + + severityFor (Namespace _ ["ConnectionRateLimiting"]) _ = Just Info + severityFor (Namespace _ ["ConnectionHardLimit"]) _ = Just Warning + severityFor (Namespace _ ["ConnectionLimitResume"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ConnectionRateLimiting"]) = Just $ mconcat + [ "Rate limiting accepting connections," + , " delaying next accept for given time, currently serving n connections." + ] + documentFor (Namespace _ ["ConnectionHardLimit"]) = Just $ mconcat + [ "Hard rate limit reached," + , " waiting until the number of connections drops below n." + ] + documentFor (Namespace _ ["ConnectionLimitResume"]) = Just + "" + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["ConnectionRateLimiting"] + , Namespace [] ["ConnectionHardLimit"] + , Namespace [] ["ConnectionLimitResume"] + ] + +-------------------------------------------------------------------------------- +-- Server Tracer +-------------------------------------------------------------------------------- + +instance (Show addr, LogFormatting addr, ToJSON addr) + => LogFormatting (Server.Trace addr) where + forMachine _dtal (TrAcceptConnection connId) = + mconcat [ "kind" .= String "AcceptConnection" + , "address" .= toJSON connId + ] + forMachine _dtal (TrAcceptError exception) = + mconcat [ "kind" .= String "AcceptErroor" + , "reason" .= show exception + ] + forMachine dtal (TrAcceptPolicyTrace policyTrace) = + mconcat [ "kind" .= String "AcceptPolicyTrace" + , "policy" .= forMachine dtal policyTrace + ] + forMachine dtal (TrServerStarted peerAddrs) = + mconcat [ "kind" .= String "AcceptPolicyTrace" + , "addresses" .= toJSON (forMachine dtal `map` peerAddrs) + ] + forMachine _dtal TrServerStopped = + mconcat [ "kind" .= String "ServerStopped" + ] + forMachine _dtal (TrServerError exception) = + mconcat [ "kind" .= String "ServerError" + , "reason" .= show exception + ] + forHuman = pack . show + +instance MetaTrace (Server.Trace addr) where + namespaceFor TrAcceptConnection {} = Namespace [] ["AcceptConnection"] + namespaceFor TrAcceptError {} = Namespace [] ["AcceptError"] + namespaceFor TrAcceptPolicyTrace {} = Namespace [] ["AcceptPolicy"] + namespaceFor TrServerStarted {} = Namespace [] ["Started"] + namespaceFor TrServerStopped {} = Namespace [] ["Stopped"] + namespaceFor TrServerError {} = Namespace [] ["Error"] + + severityFor (Namespace _ ["AcceptConnection"]) _ = Just Debug + severityFor (Namespace _ ["AcceptError"]) _ = Just Error + severityFor (Namespace _ ["AcceptPolicy"]) _ = Just Notice + severityFor (Namespace _ ["Started"]) _ = Just Notice + severityFor (Namespace _ ["Stopped"]) _ = Just Notice + severityFor (Namespace _ ["Error"]) _ = Just Critical + severityFor _ _ = Nothing + + documentFor (Namespace _ ["AcceptConnection"]) = Just "" + documentFor (Namespace _ ["AcceptError"]) = Just "" + documentFor (Namespace _ ["AcceptPolicy"]) = Just "" + documentFor (Namespace _ ["Started"]) = Just "" + documentFor (Namespace _ ["Stopped"]) = Just "" + documentFor (Namespace _ ["Error"]) = Just "" + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["AcceptConnection"] + , Namespace [] ["AcceptError"] + , Namespace [] ["AcceptPolicy"] + , Namespace [] ["Started"] + , Namespace [] ["Stopped"] + , Namespace [] ["Error"] + ] + diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index f7831a0a0f..75ffd8038a 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -381,6 +381,31 @@ library framework build-depends: Win32 >=2.5.4.1 && <3.0 hs-source-dirs: framework +library framework-cardano-logging + import: ghc-options + visibility: public + hs-source-dirs: framework/cardano-logging + exposed-modules: + Ouroboros.Network.Logging.Framework + other-modules: + Ouroboros.Network.Logging.Framework.ConnectionId + Ouroboros.Network.Logging.Framework.ConnectionManager + Ouroboros.Network.Logging.Framework.Driver + Ouroboros.Network.Logging.Framework.InboundGovernor + Ouroboros.Network.Logging.Framework.Server + build-depends: + aeson, + base >=4.14 && <4.22, + containers, + iproute, + network ^>=3.2.7, + ouroboros-network:framework, + ouroboros-network:orphan-instances, + text, + trace-dispatcher ^>= 2.10.0, + typed-protocols ^>= 1.1, + typed-protocols:stateful ^>= 1.1 + library tests-lib import: ghc-options visibility: public @@ -574,6 +599,39 @@ test-suite framework-io-tests -rtsopts -threaded +library cardano-logging + import: ghc-options + visibility: public + hs-source-dirs: cardano-logging + exposed-modules: + Ouroboros.Network.Logging + other-modules: + Ouroboros.Network.Logging.PeerSelection.ChurnCounters + Ouroboros.Network.Logging.PeerSelection.Governor + Ouroboros.Network.Logging.PeerSelection.Governor.DebugPeerSelection + Ouroboros.Network.Logging.PeerSelection.Governor.PeerSelectionCounters + Ouroboros.Network.Logging.PeerSelection.Governor.TracePeerSelection + Ouroboros.Network.Logging.PeerSelection.Governor.Utils + Ouroboros.Network.Logging.PeerSelection.PeerStateActions + Ouroboros.Network.Logging.PeerSelection.RootPeersDNS.DNSActions + Ouroboros.Network.Logging.PeerSelection.RootPeersDNS.LocalRootPeers + Ouroboros.Network.Logging.PeerSelection.RootPeersDNS.PublicRootPeers + reexported-modules: + default-language: Haskell2010 + other-extensions: + build-depends: + aeson, + base >=4.14 && <4.22, + iproute, + network, + ouroboros-network, + ouroboros-network:orphan-instances, + ouroboros-network:protocols, + text, + trace-dispatcher ^>= 2.10.0 + if flag(asserts) + ghc-options: -fno-ignore-asserts + library orphan-instances import: ghc-options visibility: public