diff --git a/cardano-diffusion/changelog.d/20260527_4683_dancewithheart_ledger_peer_usage_label.md b/cardano-diffusion/changelog.d/20260527_4683_dancewithheart_ledger_peer_usage_label.md new file mode 100644 index 0000000000..792c4c11cd --- /dev/null +++ b/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. diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs index f7d0044364..0645296781 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs +++ b/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'