From 94e39118f50d67657145f62ff045791de13a37eb Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 14 Jul 2026 17:29:31 +0200 Subject: [PATCH] Create PeerSelectionActions within withPeerSelectionActions --- .../PeerSelection/PeerSelectionActions.hs | 7 +- .../lib/Test/Cardano/Network/PeerSelection.hs | 2 +- ...0717_095439_coot_peer_selection_actions.md | 23 +++ .../lib/Ouroboros/Network/Diffusion.hs | 123 ++++++++------- .../lib/Ouroboros/Network/PeerSelection.hs | 2 + .../PeerSelection/PeerSelectionActions.hs | 148 +++++++++++++----- 6 files changed, 196 insertions(+), 109 deletions(-) create mode 100644 ouroboros-network/changelog.d/20260717_095439_coot_peer_selection_actions.md diff --git a/cardano-diffusion/lib/Cardano/Network/PeerSelection/PeerSelectionActions.hs b/cardano-diffusion/lib/Cardano/Network/PeerSelection/PeerSelectionActions.hs index a1376d8c09a..61999f67f42 100644 --- a/cardano-diffusion/lib/Cardano/Network/PeerSelection/PeerSelectionActions.hs +++ b/cardano-diffusion/lib/Cardano/Network/PeerSelection/PeerSelectionActions.hs @@ -28,13 +28,8 @@ import Network.DNS qualified as DNS import Cardano.Network.PeerSelection.ExtraRootPeers qualified as Cardano import Cardano.Network.PeerSelection.PublicRootPeers (CardanoPublicRootPeers) import Cardano.Network.PeerSelection.PublicRootPeers qualified as Cardano.PublicRootPeers -import Ouroboros.Network.PeerSelection.LedgerPeers hiding (getLedgerPeers) -import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) +import Ouroboros.Network.PeerSelection as PeerSelection import Ouroboros.Network.PeerSelection.PeerSelectionActions qualified as Ouroboros -import Ouroboros.Network.PeerSelection.RootPeersDNS (PeerActionsDNS (..), - TTL (..)) -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore (DNSSemaphore) -import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers import System.Random -- We start by reading the current ledger state judgement, if it is diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs index 1710dea486a..72598672422 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs @@ -4277,7 +4277,7 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains readUseBootstrap (Cardano.ExtraState.empty consensusMode (NumberOfBigLedgerPeers 0)) Cardano.ExtraPeers.empty actions - { requestPublicRootPeers = \_ _ -> + { Governor.requestPublicRootPeers = \_ _ -> transformPeerSelectionAction requestPublicRootPeers } policy interfaces diff --git a/ouroboros-network/changelog.d/20260717_095439_coot_peer_selection_actions.md b/ouroboros-network/changelog.d/20260717_095439_coot_peer_selection_actions.md new file mode 100644 index 00000000000..9bacca5516f --- /dev/null +++ b/ouroboros-network/changelog.d/20260717_095439_coot_peer_selection_actions.md @@ -0,0 +1,23 @@ + + +### Breaking + +- `withPeerSelectionActions` receives all arguments needed to create `PeerSelectionActions`, rather than a callback to create it. + + + diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs index 4ed434a2876..3237009a9fe 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- | This module is expected to be imported qualified. -- @@ -272,7 +273,7 @@ runM Interfaces (fuzzRng, rng3) = splitGen rng2 (cmLocalStdGen, rng4) = splitGen rng3 (cmStdGen1, rng5) = splitGen rng4 - (cmStdGen2, peerSelectionActionsRng) = splitGen rng5 + (cmStdGen2, localRootPeersRng) = splitGen rng5 mkInboundPeersMap :: IG.PublicState ntnAddr ntnVersionData -> Map ntnAddr PeerSharing @@ -610,8 +611,7 @@ runM Interfaces (PeerConnectionHandle muxMode responderCtx ntnAddr extraFlags ntnVersionData bytes m a b) m - -> ((Async m Void, Async m Void) - -> PeerSelectionActions + -> ( PeerSelectionActions extraState extraFlags extraPeers @@ -620,52 +620,57 @@ runM Interfaces (PeerConnectionHandle muxMode responderCtx ntnAddr extraFlags ntnVersionData bytes m a b) m + -> Async m Void + -> Async m Void -> m c) -> m c - withPeerSelectionActions' readInboundPeers peerStateActions = - withPeerSelectionActions dtTraceLocalRootPeersTracer - localRootsVar - dnsActions - (\getLedgerPeers -> PeerSelectionActions { - peerSelectionTargets = dcPeerSelectionTargets, - readPeerSelectionTargets = readTVar peerSelectionTargetsVar, - getLedgerStateCtx = daLedgerPeersCtx, - readLocalRootPeersFromFile = dcReadLocalRootPeers, - readLocalRootPeers = readTVar localRootsVar, - peerSharing = dcPeerSharing, - peerConnToPeerSharing = pchPeerSharing daNtnPeerSharing, - requestPeerShare = - requestPeerSharingResult (readTVar (getPeerSharingRegistry daPeerSharingRegistry)), - requestPublicRootPeers = - case daRequestPublicRootPeers of - Nothing -> - PeerSelection.requestPublicRootPeersImpl - dtTracePublicRootPeersTracer - dcReadPublicRootPeers - dnsActions - dnsSemaphore - daToExtraPeers - getLedgerPeers - Just requestPublicRootPeers' -> - requestPublicRootPeers' dnsActions dnsSemaphore daToExtraPeers getLedgerPeers, - readInboundPeers = - case dcPeerSharing of - PeerSharingDisabled -> pure Map.empty - PeerSharingEnabled -> readInboundPeers, - readLedgerPeerSnapshot = dcReadLedgerPeerSnapshot, - extraPeersAPI = daExtraPeersAPI, - peerStateActions - }) - WithLedgerPeersArgs { - wlpRng = ledgerPeersRng, - wlpConsensusInterface = daLedgerPeersCtx, - wlpTracer = dtTraceLedgerPeersTracer, - wlpGetUseLedgerPeers = dcReadUseLedgerPeers, - wlpGetLedgerPeerSnapshot = dcReadLedgerPeerSnapshot, - wlpSemaphore = dnsSemaphore, - wlpSRVPrefix = daSRVPrefix - } - peerSelectionActionsRng + withPeerSelectionActions' readInboundPeers peerStateActions k = + withLedgerPeers + dnsActions + WithLedgerPeersArgs { + wlpRng = ledgerPeersRng, + wlpConsensusInterface = daLedgerPeersCtx, + wlpTracer = dtTraceLedgerPeersTracer, + wlpGetUseLedgerPeers = dcReadUseLedgerPeers, + wlpGetLedgerPeerSnapshot = dcReadLedgerPeerSnapshot, + wlpSemaphore = dnsSemaphore, + wlpSRVPrefix = daSRVPrefix + } + $ \getLedgerPeers ledgerPeersThread -> + let args = WithPeerSelectionActionsArgs { + localRootPeersTracer = dtTraceLocalRootPeersTracer, + peerSelectionTargets = dcPeerSelectionTargets, + readPeerSelectionTargets = readTVar peerSelectionTargetsVar, + getLedgerStateCtx = daLedgerPeersCtx, + localRootPeersRng, + readLocalRootPeersFromFile = dcReadLocalRootPeers, + localRootsVar, + peerSharing = dcPeerSharing, + peerConnToPeerSharing = pchPeerSharing daNtnPeerSharing, + requestPeerShare = requestPeerSharingResult (readTVar (getPeerSharingRegistry daPeerSharingRegistry)), + requestPublicRootPeers = case daRequestPublicRootPeers of + Nothing -> + PeerSelection.requestPublicRootPeersImpl + dtTracePublicRootPeersTracer + dcReadPublicRootPeers + dnsActions + dnsSemaphore + daToExtraPeers + getLedgerPeers + Just requestPublicRootPeers' -> + requestPublicRootPeers' dnsActions dnsSemaphore daToExtraPeers getLedgerPeers, + readInboundPeers = case dcPeerSharing of + PeerSharingDisabled -> pure Map.empty + PeerSharingEnabled -> readInboundPeers, + readLedgerPeerSnapshot = dcReadLedgerPeerSnapshot, + extraPeersAPI = daExtraPeersAPI, + peerStateActions, + peerActionsDNS = dnsActions + } + in + withPeerSelectionActions args + $ \peerSelectionActions localRootPeersProviderThread -> + k peerSelectionActions ledgerPeersThread localRootPeersProviderThread peerSelectionGovernor' :: Tracer m (DebugPeerSelection extraState extraFlags extraPeers ntnAddr) @@ -773,7 +778,7 @@ runM Interfaces withPeerSelectionActions' (return Map.empty) peerStateActions $ - \(ledgerPeersThread, localRootPeersProviderThread) peerSelectionActions-> + \peerSelectionActions ledgerPeersThread localRootPeersProviderThread -> Async.withAsync (peerSelectionGovernor' dtDebugPeerSelectionTracer @@ -807,7 +812,7 @@ runM Interfaces withPeerSelectionActions' (mkInboundPeersMap <$> readInboundState) peerStateActions $ - \(ledgerPeersThread, localRootPeersProviderThread) peerSelectionActions -> + \peerSelectionActions ledgerPeersThread localRootPeersProviderThread -> Async.withAsync (do labelThisThread "Peer selection governor" diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection.hs index 64b1102b771..c0107d45bbc 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + module Ouroboros.Network.PeerSelection ( module Governor , module PeerSelection diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs index af04233cb14..c544a39f9f3 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} @@ -9,6 +10,7 @@ module Ouroboros.Network.PeerSelection.PeerSelectionActions ( PeerSelectionActions (..) + , WithPeerSelectionActionsArgs (..) , withPeerSelectionActions , requestPeerSharingResult , requestPublicRootPeersImpl @@ -33,19 +35,65 @@ import Data.Void (Void) import Network.DNS qualified as DNS import Ouroboros.Network.PeerSelection.Governor.Types - (PeerSelectionActions (PeerSelectionActions, readLocalRootPeersFromFile)) import Ouroboros.Network.PeerSelection.LedgerPeers hiding (getLedgerPeers) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) +-- import Ouroboros.Network.PeerSelection.PeerStateActions (PeerConnectionHandle) +import Ouroboros.Network.PeerSelection.PeerSharing import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.PeerSelection.RootPeersDNS -import Ouroboros.Network.PeerSelection.State.LocalRootPeers -import Ouroboros.Network.PeerSharing (PeerSharingController, - PeerSharingResult (..), requestPeers) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers +import Ouroboros.Network.PeerSelection.Types +import Ouroboros.Network.PeerSharing (PeerSharingController, requestPeers) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..)) import System.Random +data WithPeerSelectionActionsArgs extraState extraFlags extraPeers extraAPI peeraddr peerconn resolver m a = + WithPeerSelectionActionsArgs { + localRootPeersTracer :: Tracer m (TraceLocalRootPeers extraFlags peeraddr), + -- ^ trace local root peers + peerSelectionTargets :: PeerSelectionTargets, + -- ^ initial peer selection targets + readPeerSelectionTargets :: STM m PeerSelectionTargets, + -- ^ read peer selection targets + getLedgerStateCtx :: LedgerPeersConsensusInterface extraAPI m, + -- ^ ledger peer consensus API + + -- + -- local root peerr + -- + + localRootPeersRng :: StdGen, + readLocalRootPeersFromFile :: STM m (LocalRootPeers.Config extraFlags RelayAccessPoint), + localRootsVar :: StrictTVar m (LocalRootPeers.Config extraFlags peeraddr), + + -- + -- peer sharing + -- + + peerSharing :: PeerSharing, + -- ^ configuration value of peer sharing + peerConnToPeerSharing :: peerconn -> PeerSharing, + -- ^ handshake negotiated value of peer sharing + requestPeerShare :: PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr), + -- ^ request peers through peer sharing callback + + requestPublicRootPeers :: SomeLedgerPeersKind + -> StdGen + -> Int + -> m (PublicRootPeers extraPeers peeraddr, DiffTime), + -- ^ request public root peers callback + readInboundPeers :: m (Map peeraddr PeerSharing), + -- ^ inbound peers which are injected into results of peer sharing + -- depending on the `PeerSharing` value + readLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers)), + -- ^ read ledger peer snapshot, it is read form a TVar which can be updated on SIGHUP from a file. + extraPeersAPI :: PublicExtraPeersAPI extraPeers peeraddr, + peerStateActions :: PeerStateActions peeraddr extraFlags peerconn m, + peerActionsDNS :: PeerActionsDNS peeraddr resolver m + } + withPeerSelectionActions :: forall extraState extraFlags extraPeers extraAPI peeraddr peerconn resolver m a. ( Alternative (STM m) @@ -55,51 +103,65 @@ withPeerSelectionActions , Ord peeraddr , Eq extraFlags ) - => Tracer m (TraceLocalRootPeers extraFlags peeraddr) - -> StrictTVar m (Config extraFlags peeraddr) - -> PeerActionsDNS peeraddr resolver m - -> ( ( NumberOfPeers - -> SomeLedgerPeersKind - -> m (Maybe (Set peeraddr, DiffTime)) - ) - -> PeerSelectionActions extraState extraFlags extraPeers extraAPI peeraddr peerconn m) - -- ^ construct PeerSelectionActions given a function which obtains ledger - -- peers that is supplied by `withLedgerPeers`. - -> WithLedgerPeersArgs extraAPI m - -> StdGen - -> ( (Async m Void, Async m Void) - -> PeerSelectionActions extraState extraFlags extraPeers extraAPI peeraddr peerconn m + => WithPeerSelectionActionsArgs extraState extraFlags extraPeers extraAPI peeraddr peerconn resolver m a + -> ( PeerSelectionActions extraState extraFlags extraPeers extraAPI peeraddr peerconn m + -> Async m Void -> m a) -- ^ continuation, receives a handle to the local roots peer provider thread -- (only if local root peers were non-empty). -> m a withPeerSelectionActions - localTracer - localRootsVar - peerActionsDNS - getPeerSelectionActions - ledgerPeersArgs - rng0 + WithPeerSelectionActionsArgs { + localRootPeersTracer, + peerSelectionTargets, + readPeerSelectionTargets, + getLedgerStateCtx, + localRootPeersRng, + readLocalRootPeersFromFile, + localRootsVar, + peerSharing, + peerConnToPeerSharing, + requestPeerShare, + requestPublicRootPeers, + readInboundPeers, + readLedgerPeerSnapshot, + extraPeersAPI, + peerStateActions, + peerActionsDNS + } k = do - withLedgerPeers - peerActionsDNS - ledgerPeersArgs - (\getLedgerPeers lpThread -> do - let peerSelectionActions@PeerSelectionActions - { readLocalRootPeersFromFile - } = getPeerSelectionActions getLedgerPeers - withAsync do - labelThisThread "local-roots-peers" - localRootPeersProvider - localTracer - peerActionsDNS - -- NOTE: we don't set `resolvConcurrent` because - -- of https://github.com/kazu-yamamoto/dns/issues/174 - DNS.defaultResolvConf - rng0 - readLocalRootPeersFromFile - localRootsVar - (\lrppThread -> k (lpThread, lrppThread) peerSelectionActions)) + let peerSelectionActions = + PeerSelectionActions { + peerSelectionTargets, + readPeerSelectionTargets, + getLedgerStateCtx, + readLocalRootPeersFromFile, + readLocalRootPeers = readTVar localRootsVar, + peerSharing, + peerConnToPeerSharing, + requestPeerShare, + requestPublicRootPeers, + readInboundPeers = + case peerSharing of + PeerSharingDisabled -> pure Map.empty + PeerSharingEnabled -> readInboundPeers, + readLedgerPeerSnapshot, + extraPeersAPI, + peerStateActions + } + withAsync + (do + labelThisThread "local-roots-peers" + localRootPeersProvider + localRootPeersTracer + peerActionsDNS + -- NOTE: we don't set `resolvConcurrent` because + -- of https://github.com/kazu-yamamoto/dns/issues/174 + DNS.defaultResolvConf + localRootPeersRng + readLocalRootPeersFromFile + localRootsVar) + (k peerSelectionActions) requestPeerSharingResult :: ( MonadSTM m , MonadMVar m