cardano-diffusion: label ledger peer usage

cardano-diffusion/changelog.d/20260527_4683_dancewithheart_ledger_peer_usage_label.md

@@ -0,0 +1,3 @@
+### Non-Breaking
+
+- Add a diffusion test label showing the distribution of ledger peer usage.

cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs

@@ -2093,9 +2093,100 @@ prop_peer_selection_trace_coverage defaultBearerInfo diffScript =
         "TraceVerifyPeerSnapshot " <> show result
       eventsSeenNames = map peerSelectionTraceMap events
 
+      (ledgerPeerResultLabels, ledgerPeerActionLabels) = ledgerPeerLabelsFromTrace events
+
+      -- Generic peer-selection actions, such as 'TracePromoteWarmPeers',
+      -- only carry the selected peers. They do not say whether those peers
+      -- are ledger peers.
+      --
+      -- This is a trace-derived classification: generic peer-action events are
+      -- classified using the ledger-peer set from the most recent debug-state
+      -- snapshot in the same ordered trace stream. Before the first debug
+      -- snapshot, generic actions are left unclassified.
+      --
+      -- The first result list reports ledger-peer result sizes. The second
+      -- result list reports how many ledger peers were selected by actions.
+      ledgerPeerLabelsFromTrace
+        :: [TracePeerSelection Cardano.ExtraState
+                               PeerTrustable
+                               (ExtraPeers NtNAddr)
+                               NtNAddr]
+        -> ([String], [String])
+      ledgerPeerLabelsFromTrace =
+        go Nothing
+        where
+          go
+            :: Maybe (Set NtNAddr)
+            -- ^ Ledger peers from the most recent 'TraceDebugState', if any.
+            -> [TracePeerSelection Cardano.ExtraState
+                                   PeerTrustable
+                                   (ExtraPeers NtNAddr)
+                                   NtNAddr]
+            -> ([String], [String])
+          go _ [] = ([], [])
+          go _ (TraceDebugState _ st : evs) =
+            let currentLedgerPeers = PublicRootPeers.getLedgerPeers (dpssPublicRootPeers st)
+            in go (Just currentLedgerPeers) evs
+          go mbLedgerPeers (event : evs) =
+            let (resultLabels, actionLabels) = go mbLedgerPeers evs
+                resultLabels' =
+                  case ledgerPeerResultLabel event of
+                    Nothing -> resultLabels
+                    Just rl -> rl : resultLabels
+                actionLabels' =
+                  case ledgerPeerActionLabel mbLedgerPeers event of
+                    Nothing -> actionLabels
+                    Just al -> al : actionLabels
+             in (resultLabels', actionLabels')
+
+      ledgerPeerResultLabel
+        :: TracePeerSelection extraDebugState extraFlags extraPeers peeraddr
+        -> Maybe String
+      ledgerPeerResultLabel = \case
+        TraceBigLedgerPeersResults peers _ _ ->
+          Just $ "TraceBigLedgerPeersResults " ++ show (Set.size peers)
+        TracePublicRootsResults publicRootPeers _ _ ->
+          let ledgerPeers = PublicRootPeers.getLedgerPeers publicRootPeers
+          in Just $ "TracePublicRootsResults ledger peers " ++ show (Set.size ledgerPeers)
+        _ -> Nothing
+
+      ledgerPeerActionLabel
+        :: Maybe (Set NtNAddr)
+        -> TracePeerSelection Cardano.ExtraState PeerTrustable (ExtraPeers NtNAddr) NtNAddr
+        -> Maybe String
+      ledgerPeerActionLabel mbLedgerPeers = \case
+        TraceForgetBigLedgerPeers _ _ peers -> Just $ "TraceForgetBigLedgerPeers " ++ show (Set.size peers)
+        TracePromoteColdBigLedgerPeers _ _ peers -> Just $ "TracePromoteColdBigLedgerPeers " ++ show (Set.size peers)
+        TracePromoteWarmBigLedgerPeers _ _ peers -> Just $ "TracePromoteWarmBigLedgerPeers " ++ show (Set.size peers)
+        TraceDemoteWarmBigLedgerPeers _ _ peers -> Just $ "TraceDemoteWarmBigLedgerPeers " ++ show (Set.size peers)
+        TraceDemoteHotBigLedgerPeers _ _ peers -> Just $ "TraceDemoteHotBigLedgerPeers " ++ show (Set.size peers)
+        TracePromoteColdPeers _ _ peers ->
+          labelLedgerPeerIntersection "TracePromoteColdPeers ledger peers" mbLedgerPeers peers
+        TracePromoteWarmPeers _ _ peers ->
+          labelLedgerPeerIntersection "TracePromoteWarmPeers ledger peers" mbLedgerPeers peers
+        TraceDemoteWarmPeers _ _ peers ->
+          labelLedgerPeerIntersection "TraceDemoteWarmPeers ledger peers" mbLedgerPeers peers
+        TraceDemoteHotPeers _ _ peers ->
+          labelLedgerPeerIntersection "TraceDemoteHotPeers ledger peers" mbLedgerPeers peers
+        TraceForgetColdPeers _ _ peers ->
+          labelLedgerPeerIntersection "TraceForgetColdPeers ledger peers" mbLedgerPeers peers
+        _ -> Nothing
+
+      labelLedgerPeerIntersection
+        :: String
+        -> Maybe (Set NtNAddr)
+        -> Set NtNAddr
+        -> Maybe String
+      labelLedgerPeerIntersection _ Nothing _ = Nothing
+      labelLedgerPeerIntersection name (Just ledgerPeers) peers =
+        let selectedLedgerPeers = Set.intersection ledgerPeers peers
+         in Just $ name ++ " " ++ show (Set.size selectedLedgerPeers)
+
    -- TODO: Add checkCoverage here
    in tabulate "peer selection trace" eventsSeenNames
-      True
+       $ tabulate "ledger peer result sizes" ledgerPeerResultLabels
+       $ tabulate "ledger peers selected by actions" ledgerPeerActionLabels
+         True
 
 -- | A variant of
 -- 'Test.Ouroboros.Network.ConnectionHandler.Network.PeerSelection.prop_governor_nolivelock'