Refactored withPeerSelectionActions

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

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

ouroboros-network/changelog.d/20260717_095439_coot_peer_selection_actions.md

@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+### Breaking
+
+- `withPeerSelectionActions` receives all arguments needed to create `PeerSelectionActions`, rather than a callback to create it.
+
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->

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"

ouroboros-network/lib/Ouroboros/Network/PeerSelection.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
 module Ouroboros.Network.PeerSelection
   ( module Governor
   , module PeerSelection