Follow proper tracing type for blockfetch decision

IntersectMBO · Jul 15, 2024 · 0a1ebc6 · 0a1ebc6
1 parent 124b702
commit 0a1ebc6
Show file tree

Hide file tree

Showing 5 changed files with 51 additions and 35 deletions.
diff --git a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs
@@ -48,7 +48,7 @@ import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import           Ouroboros.Network.Block (Point (..), SlotNo, Tip)
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
-import           Ouroboros.Network.BlockFetch.Decision
+import           Ouroboros.Network.BlockFetch.Decision.Trace as BlockFetch
 import           Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..))
 import           Ouroboros.Network.ConnectionId (ConnectionId)
 import           Ouroboros.Network.ConnectionManager.Types (ConnectionManagerTrace (..))
@@ -146,9 +146,7 @@ getAllNamespaces =
         chainSyncServerBlockNS = map (nsGetTuple . nsReplacePrefix ["ChainSync", "ServerBlock"])
                         (allNamespaces :: [Namespace (TraceChainSyncServerEvent blk)])
         blockFetchDecisionNS = map (nsGetTuple . nsReplacePrefix ["BlockFetch", "Decision"])
-                        (allNamespaces :: [Namespace [BlockFetch.TraceLabelPeer
-                                                      remotePeer
-                                                      (FetchDecision [Point (Header blk)])]])
+                        (allNamespaces :: [Namespace (TraceDecisionEvent remotePeer (Header blk))])
         blockFetchClientNS = map (nsGetTuple . nsReplacePrefix ["BlockFetch", "Client"])
                         (allNamespaces :: [Namespace (BlockFetch.TraceLabelPeer
                                                       remotePeer

diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs
@@ -57,7 +57,7 @@ import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import           Ouroboros.Network.Block (Point (..), Serialised, SlotNo, Tip)
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
-import           Ouroboros.Network.BlockFetch.Decision
+import qualified Ouroboros.Network.BlockFetch.Decision.Trace as BlockFetch
 import           Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..))
 import           Ouroboros.Network.ConnectionId (ConnectionId)
 import           Ouroboros.Network.ConnectionManager.Types (ConnectionManagerTrace (..))
@@ -270,9 +270,7 @@ docTracersFirstPhase condConfigFileName = do
                 ["BlockFetch", "Decision"]
     configureTracers configReflection trConfig [blockFetchDecisionTr]
     blockFetchDecisionTrDoc <- documentTracer (blockFetchDecisionTr ::
-       Trace IO [BlockFetch.TraceLabelPeer
-                                      remotePeer
-                                      (FetchDecision [Point (Header blk)])])
+       Trace IO (BlockFetch.TraceDecisionEvent remotePeer (Header blk)))
 
     blockFetchClientTr  <- mkCardanoTracer
                 trBase trForward mbTrEKG

diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs
@@ -60,6 +60,7 @@ import           Ouroboros.Network.Block hiding (blockPrevHash)
 import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
 import           Ouroboros.Network.BlockFetch.Decision
+import           Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..))
 import           Ouroboros.Network.ConnectionId (ConnectionId (..))
 import           Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..))
 import           Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..))
@@ -624,43 +625,43 @@ calculateBlockFetchClientMetrics cm _lc _ = pure cm
 --------------------------------------------------------------------------------
 
 instance (LogFormatting peer, Show peer) =>
-    LogFormatting [TraceLabelPeer peer (FetchDecision [Point header])] where
-  forMachine DMinimal _ = mempty
-  forMachine _ []       = mconcat
+    LogFormatting (TraceDecisionEvent peer header) where
+  forMachine DMinimal (PeersFetch _) = mempty
+  forMachine _ (PeersFetch [])       = mconcat
     [ "kind"  .= String "EmptyPeersFetch"]
-  forMachine _ xs       = mconcat
+  forMachine _ (PeersFetch xs)       = mconcat
     [ "kind"  .= String "PeersFetch"
     , "peers" .= toJSON
       (foldl' (\acc x -> forMachine DDetailed x : acc) [] xs) ]
 
-  asMetrics peers = [IntM "BlockFetch.ConnectedPeers" (fromIntegral (length peers))]
+  asMetrics (PeersFetch peers) = [IntM "BlockFetch.ConnectedPeers" (fromIntegral (length peers))]
 
-instance MetaTrace [TraceLabelPeer peer (FetchDecision [Point header])] where
-  namespaceFor (a : _tl) = (nsCast . namespaceFor) a
-  namespaceFor [] = Namespace [] ["EmptyPeersFetch"]
+instance MetaTrace (TraceDecisionEvent peer header) where
+  namespaceFor (PeersFetch (a : _tl)) = (nsCast . namespaceFor) a
+  namespaceFor (PeersFetch []) = Namespace [] ["EmptyPeersFetch"]
 
   severityFor (Namespace [] ["EmptyPeersFetch"]) _ = Just Debug
   severityFor ns Nothing =
     severityFor (nsCast ns :: Namespace (FetchDecision [Point header])) Nothing
-  severityFor ns (Just []) =
+  severityFor ns (Just (PeersFetch [])) =
     severityFor (nsCast ns :: Namespace (FetchDecision [Point header])) Nothing
-  severityFor ns (Just ((TraceLabelPeer _ a) : _tl)) =
+  severityFor ns (Just (PeersFetch ((TraceLabelPeer _ a) : _tl))) =
     severityFor (nsCast ns) (Just a)
 
   privacyFor (Namespace _ ["EmptyPeersFetch"]) _ = Just Public
   privacyFor ns Nothing =
     privacyFor (nsCast ns :: Namespace (FetchDecision [Point header])) Nothing
-  privacyFor ns (Just []) =
+  privacyFor ns (Just (PeersFetch [])) =
     privacyFor (nsCast ns :: Namespace (FetchDecision [Point header])) Nothing
-  privacyFor ns (Just ((TraceLabelPeer _ a) : _tl)) =
+  privacyFor ns (Just (PeersFetch ((TraceLabelPeer _ a) : _tl))) =
     privacyFor (nsCast ns) (Just a)
 
   detailsFor (Namespace _ ["EmptyPeersFetch"]) _ = Just DNormal
   detailsFor ns Nothing =
     detailsFor (nsCast ns :: Namespace (FetchDecision [Point header])) Nothing
-  detailsFor ns (Just []) =
+  detailsFor ns (Just (PeersFetch [])) =
     detailsFor (nsCast ns :: Namespace (FetchDecision [Point header])) Nothing
-  detailsFor ns (Just ((TraceLabelPeer _ a) : _tl)) =
+  detailsFor ns (Just (PeersFetch ((TraceLabelPeer _ a) : _tl))) =
     detailsFor (nsCast ns) (Just a)
   documentFor ns = documentFor (nsCast ns :: Namespace (FetchDecision [Point header]))
   metricsDocFor ns = metricsDocFor (nsCast ns :: Namespace (FetchDecision [Point header]))

diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs
@@ -38,6 +38,7 @@ import           Ouroboros.Network.BlockFetch.ClientState (TraceFetchClientState
                    TraceLabelPeer (..))
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
 import           Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline (..))
+import           Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..))
 import           Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..))
 import           Ouroboros.Network.ConnectionId (ConnectionId (..))
 import           Ouroboros.Network.ConnectionManager.Types (AbstractState (..),
@@ -2632,3 +2633,19 @@ instance FromJSON PeerTrustable where
 instance ToJSON PeerTrustable where
   toJSON IsTrustable = Bool True
   toJSON IsNotTrustable = Bool False
+
+
+instance HasPrivacyAnnotation (TraceDecisionEvent peer header) where
+instance HasSeverityAnnotation (TraceDecisionEvent peer header) where
+  getSeverityAnnotation _ = Debug
+instance ToObject peer
+      => Transformable Text IO (TraceDecisionEvent peer header) where
+  trTransformer = trStructuredText
+instance HasTextFormatter (TraceDecisionEvent peer header) where
+
+instance ToObject peer => ToObject (TraceDecisionEvent peer header) where
+  toObject verb (PeersFetch decisions) =
+    mconcat
+      [ "kind" .= String "PeersFetch"
+      , "decisions" .= toObject verb decisions
+      ]
diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs
@@ -86,11 +86,12 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
 import           Ouroboros.Consensus.Util.Enclose
 import qualified Ouroboros.Network.AnchoredFragment as AF
-import           Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), HasHeader (..), Point,
+import           Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), HasHeader (..),
                    StandardHash, blockNo, pointSlot, unBlockNo)
 import           Ouroboros.Network.BlockFetch.ClientState (TraceFetchClientState (..),
                    TraceLabelPeer (..))
-import           Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline (..))
+import           Ouroboros.Network.BlockFetch.Decision (FetchDecline (..))
+import           Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..))
 import           Ouroboros.Network.ConnectionId (ConnectionId)
 import           Ouroboros.Network.ConnectionManager.Types (ConnectionManagerCounters (..),
                    ConnectionManagerTrace (..))
@@ -290,12 +291,12 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where
   reportelided t tr ev count = defaultelidedreporting  t tr ev count
 
 instance (StandardHash header, Eq peer) => ElidingTracer
-  (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]) where
+  (WithSeverity (TraceDecisionEvent peer header)) where
   -- equivalent by type and severity
   isEquivalent (WithSeverity s1 _peers1)
                (WithSeverity s2 _peers2) = s1 == s2
   -- the types to be elided
-  doelide (WithSeverity _ peers) =
+  doelide (WithSeverity _ (PeersFetch peers)) =
     let checkDecision :: TraceLabelPeer peer (Either FetchDecline result) -> Bool
         checkDecision (TraceLabelPeer _peer (Left FetchDeclineChainNotPlausible)) = True
         checkDecision (TraceLabelPeer _peer (Left (FetchDeclineConcurrencyLimit _ _))) = True
@@ -1409,9 +1410,9 @@ teeTraceBlockFetchDecision
        , ToObject peer
        )
     => TracingVerbosity
-    -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer)
+    -> MVar (Maybe (WithSeverity (TraceDecisionEvent peer (Header blk))),Integer)
     -> Trace IO Text
-    -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
+    -> Tracer IO (WithSeverity (TraceDecisionEvent peer (Header blk)))
 teeTraceBlockFetchDecision verb eliding tr =
   Tracer $ \ev -> do
     traceWith (teeTraceBlockFetchDecision' meTr) ev
@@ -1422,12 +1423,13 @@ teeTraceBlockFetchDecision verb eliding tr =
 
 teeTraceBlockFetchDecision'
     :: Trace IO Text
-    -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
+    -> Tracer IO (WithSeverity (TraceDecisionEvent peer (Header blk)))
 teeTraceBlockFetchDecision' tr =
-    Tracer $ \(WithSeverity _ peers) -> do
-      meta <- mkLOMeta Info Confidential
-      let tr' = appendName "peers" tr
-      traceNamedObject tr' (meta, LogValue "connectedPeers" . PureI $ fromIntegral $ length peers)
+    Tracer $ \case
+      WithSeverity _ (PeersFetch peers) -> do
+        meta <- mkLOMeta Info Confidential
+        let tr' = appendName "peers" tr
+        traceNamedObject tr' (meta, LogValue "connectedPeers" . PureI $ fromIntegral $ length peers)
 
 teeTraceBlockFetchDecisionElide
     :: ( Eq peer
@@ -1436,9 +1438,9 @@ teeTraceBlockFetchDecisionElide
        , ToObject peer
        )
     => TracingVerbosity
-    -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer)
+    -> MVar (Maybe (WithSeverity (TraceDecisionEvent peer (Header blk))),Integer)
     -> Trace IO Text
-    -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
+    -> Tracer IO (WithSeverity (TraceDecisionEvent peer (Header blk)))
 teeTraceBlockFetchDecisionElide = elideToLogObject
 
 --------------------------------------------------------------------------------