From 5cf418c200e313ac11726f0dcedabbc448ee9aed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Sun, 11 Feb 2024 18:53:32 +0100 Subject: [PATCH 1/2] refactor withPeerSelectionAction argument list --- ouroboros-network/CHANGELOG.md | 1 + ouroboros-network/ouroboros-network.cabal | 1 + .../Test/Ouroboros/Network/LedgerPeers.hs | 24 ++- .../src/Ouroboros/Network/Diffusion/P2P.hs | 134 ++++++-------- .../Network/PeerSelection/LedgerPeers.hs | 31 ++-- .../PeerSelection/PeerSelectionActions.hs | 168 +++++++++--------- .../Network/PeerSelection/RootPeersDNS.hs | 18 ++ 7 files changed, 192 insertions(+), 185 deletions(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index a53372f393f..e8542960a96 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -15,6 +15,7 @@ * Updated type of constructor in `TraceLocalRootPeers` * Added `TraceDebugState` message to `TracePeerSelection` for tracing peer selection upon getting a USR1 sig. +* Changed withPeerSelectionActions and withLedgerPeers signatures ### Non-breaking changes diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 5c24e8f270e..c537cb443e8 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -55,6 +55,7 @@ library Ouroboros.Network.PeerSelection.State.EstablishedPeers Ouroboros.Network.PeerSelection.State.KnownPeers Ouroboros.Network.PeerSelection.State.LocalRootPeers + Ouroboros.Network.PeerSelection.RootPeersDNS Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs index 6a6f416acf5..2009a0e8540 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs @@ -36,7 +36,7 @@ import Cardano.Slotting.Slot (SlotNo, WithOrigin (..)) import Control.Concurrent.Class.MonadSTM.Strict import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.RelayAccessPoint -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore +import Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.Testing.Data.Script import Test.Ouroboros.Network.PeerSelection.RootPeersDNS import Test.QuickCheck @@ -186,10 +186,13 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoot dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore withLedgerPeers - rng dnsSemaphore (curry IP.toSockAddr) verboseTracer - (pure (UseLedgerPeers Always)) - interface - (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar) + PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr, + paDnsActions = (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar), + paDnsSemaphore = dnsSemaphore } + WithLedgerPeersArgs { wlpRng = rng, + wlpConsensusInterface = interface, + wlpTracer = verboseTracer, + wlpGetUseLedgerPeers = pure $ UseLedgerPeers Always } (\request _ -> do threadDelay 1900 -- we need to invalidate ledger peer's cache resp <- request (NumberOfPeers 1) ledgerPeersKind @@ -243,10 +246,13 @@ prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed (Moc dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore withLedgerPeers - rng dnsSemaphore (curry IP.toSockAddr) verboseTracer - (pure (UseLedgerPeers (After 0))) - interface - (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar) + PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr, + paDnsActions = mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar, + paDnsSemaphore = dnsSemaphore } + WithLedgerPeersArgs { wlpRng = rng, + wlpConsensusInterface = interface, + wlpTracer = verboseTracer, + wlpGetUseLedgerPeers = pure $ UseLedgerPeers (After 0) } (\request _ -> do threadDelay 1900 -- we need to invalidate ledger peer's cache resp <- request (NumberOfPeers count) ledgerPeersKind diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs index d28dd6fefbd..661be62e6d8 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -105,15 +105,15 @@ import Ouroboros.Network.PeerSelection.Governor qualified as Governor import Ouroboros.Network.PeerSelection.Governor.Types (ChurnMode (ChurnModeNormal), DebugPeerSelection (..), PeerSelectionActions, PeerSelectionCounters (..), - PeerSelectionPolicy (..), PeerSelectionState, PeerStateActions, + PeerSelectionPolicy (..), PeerSelectionState, PublicPeerSelectionState (..), TracePeerSelection (..), emptyPeerSelectionState, emptyPublicPeerSelectionState) #ifdef POSIX import Ouroboros.Network.PeerSelection.Governor.Types (makeDebugPeerSelectionState) #endif -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface, TraceLedgerPeers) +import Ouroboros.Network.PeerSelection.LedgerPeers (TraceLedgerPeers, + WithLedgerPeersArgs (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeersConsensusInterface (..), UseLedgerPeers) #ifdef POSIX @@ -129,6 +129,7 @@ import Ouroboros.Network.PeerSelection.PeerStateActions (PeerConnectionHandle, pchPeerSharing, withPeerStateActions) import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) +import Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSActions, DNSLookupType (..), ioDNSActions) import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers @@ -950,24 +951,13 @@ runM Interfaces spsExitPolicy = exitPolicy } + dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore -- -- Run peer selection (p2p governor) -- let withPeerSelectionActions' :: forall muxMode responderCtx peerAddr bytes a1 b c. - STM m (ntnAddr, PeerSharing) - -- ^ Read New Inbound Connections - -> PeerStateActions - ntnAddr - (PeerConnectionHandle - muxMode responderCtx peerAddr ntnVersionData bytes m a1 b) - m - -> StdGen - -- ^ Random generator for picking ledger peers - -> LedgerPeersConsensusInterface m - -- ^ Get Ledger Peers comes from here - -> STM m UseLedgerPeers - -- ^ Get Use Ledger After value + PeerSelectionActionsDiffusionMode ntnAddr (PeerConnectionHandle muxMode responderCtx peerAddr ntnVersionData bytes m a1 b) m -> ( (Async m Void, Async m Void) -> PeerSelectionActions ntnAddr @@ -979,20 +969,26 @@ runM Interfaces -- (only if local root peers were non-empty). -> m c withPeerSelectionActions' = - withPeerSelectionActions - dtTraceLocalRootPeersTracer - dtTracePublicRootPeersTracer - dtTraceLedgerPeersTracer - diNtnToPeerAddr - (diDnsActions lookupReqs) - (readTVar peerSelectionTargetsVar) - lpGetLedgerStateJudgement - daReadLocalRootPeers - daReadPublicRootPeers - daReadUseBootstrapPeers - daOwnPeerSharing - (pchPeerSharing diNtnPeerSharing) - (readTVar (getPeerSharingRegistry daPeerSharingRegistry)) + withPeerSelectionActions PeerActionsDNS { + paToPeerAddr = diNtnToPeerAddr, + paDnsActions = diDnsActions lookupReqs, + paDnsSemaphore = dnsSemaphore } + PeerSelectionActionsArgs { + psLocalRootPeersTracer = dtTraceLocalRootPeersTracer, + psPublicRootPeersTracer = dtTracePublicRootPeersTracer, + psReadTargets = readTVar peerSelectionTargetsVar, + psJudgement = lpGetLedgerStateJudgement, + psReadLocalRootPeers = daReadLocalRootPeers, + psReadPublicRootPeers = daReadPublicRootPeers, + psReadUseBootstrapPeers = daReadUseBootstrapPeers, + psPeerSharing = daOwnPeerSharing, + psPeerConnToPeerSharing = pchPeerSharing diNtnPeerSharing, + psReadPeerSharingController = readTVar (getPeerSharingRegistry daPeerSharingRegistry) } + WithLedgerPeersArgs { + wlpRng = ledgerPeersRng, + wlpConsensusInterface = daLedgerPeersCtx, + wlpTracer = dtTraceLedgerPeersTracer, + wlpGetUseLedgerPeers = daReadUseLedgerPeers } peerSelectionGovernor' :: forall (muxMode :: MuxMode) b. @@ -1072,27 +1068,20 @@ runM Interfaces diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics withPeerStateActions' connectionManager $ \peerStateActions-> withPeerSelectionActions' - retry - peerStateActions - ledgerPeersRng - daLedgerPeersCtx - daReadUseLedgerPeers - $ \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> - - Async.withAsync - (peerSelectionGovernor' + PeerSelectionActionsDiffusionMode { + psNewInboundConnections = retry, + psPeerStateActions = peerStateActions } $ + \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> + Async.withAsync + (peerSelectionGovernor' dtDebugPeerSelectionInitiatorTracer debugStateVar - peerSelectionActions) - $ \governorThread -> - Async.withAsync peerChurnGovernor' $ \churnGovernorThread -> - -- wait for any thread to fail: - snd <$> Async.waitAny - [ ledgerPeersThread - , localRootPeersProvider - , governorThread - , churnGovernorThread - ] + peerSelectionActions) $ \governorThread -> + Async.withAsync + peerChurnGovernor' $ \churnGovernorThread -> + -- wait for any thread to fail: + snd <$> Async.waitAny + [ledgerPeersThread, localRootPeersProvider, governorThread, churnGovernorThread] -- InitiatorAndResponder mode, run peer selection and the server: InitiatorAndResponderDiffusionMode -> do @@ -1100,39 +1089,28 @@ runM Interfaces outboundInfoChannel <- newInformationChannel observableStateVar <- Server.newObservableStateVar ntnInbgovRng withConnectionManagerInitiatorAndResponderMode - inboundInfoChannel outboundInfoChannel + inboundInfoChannel + outboundInfoChannel observableStateVar $ \connectionManager-> do debugStateVar <- newTVarIO $ emptyPeerSelectionState fuzzRng [] diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics - withPeerStateActions' connectionManager $ \peerStateActions-> + withPeerStateActions' connectionManager $ \peerStateActions -> withPeerSelectionActions' - (readMessage outboundInfoChannel) - peerStateActions - ledgerPeersRng - daLedgerPeersCtx - daReadUseLedgerPeers - $ \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> - Async.withAsync - (peerSelectionGovernor' - dtDebugPeerSelectionInitiatorResponderTracer - debugStateVar - peerSelectionActions) $ \governorThread -> - -- begin, unique to InitiatorAndResponder mode: - withSockets' $ \sockets addresses -> do - traceWith tracer (RunServer addresses) - Async.withAsync - (serverRun' sockets connectionManager inboundInfoChannel - observableStateVar) $ \serverThread -> - -- end, unique to ... - Async.withAsync peerChurnGovernor' $ \churnGovernorThread -> - -- wait for any thread to fail: - snd <$> Async.waitAny - [ ledgerPeersThread - , localRootPeersProvider - , governorThread - , churnGovernorThread - , serverThread - ] + PeerSelectionActionsDiffusionMode { + psNewInboundConnections = readMessage outboundInfoChannel, + psPeerStateActions = peerStateActions } $ + \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> + Async.withAsync + (peerSelectionGovernor' dtDebugPeerSelectionInitiatorResponderTracer debugStateVar peerSelectionActions) $ \governorThread -> + -- begin, unique to InitiatorAndResponder mode: + withSockets' $ \sockets addresses -> do + traceWith tracer (RunServer addresses) + Async.withAsync + (serverRun' sockets connectionManager inboundInfoChannel observableStateVar) $ \serverThread -> + -- end, unique to ... + Async.withAsync peerChurnGovernor' $ \churnGovernorThread -> + -- wait for any thread to fail: + snd <$> Async.waitAny [ledgerPeersThread, localRootPeersProvider, governorThread, churnGovernorThread, serverThread] -- | Main entry point for data diffusion service. It allows to: -- diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs index ca144ca3174..ec8e6cff7f0 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -5,7 +5,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -29,6 +28,7 @@ module Ouroboros.Network.PeerSelection.LedgerPeers , accBigPoolStake , bigLedgerPeerQuota -- * DNS based provider for ledger root peers + , WithLedgerPeersArgs (..) , withLedgerPeers -- Re-exports for testing purposes , module Ouroboros.Network.PeerSelection.LedgerPeers.Type @@ -65,8 +65,8 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Common import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.PeerSelection.RelayAccessPoint import Ouroboros.Network.PeerSelection.RelayAccessPoint qualified as Socket +import Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers (resolveLedgerPeers) @@ -394,6 +394,18 @@ ledgerPeersThread inRng dnsSemaphore toPeerAddr tracer readUseLedgerAfter addrs' = Set.insert addr addrs in (addrs', domains) +-- | Argument record for withLedgerPeers +-- +data WithLedgerPeersArgs m = WithLedgerPeersArgs { + wlpRng :: StdGen, + -- ^ Random generator for picking ledger peers + wlpConsensusInterface :: LedgerPeersConsensusInterface m, + wlpTracer :: Tracer m TraceLedgerPeers, + -- ^ Get Ledger Peers comes from here + wlpGetUseLedgerPeers :: STM m UseLedgerPeers + -- ^ Get Use Ledger After value + } + -- | For a LedgerPeers worker thread and submit request and receive responses. -- withLedgerPeers :: forall peerAddr resolver exception m a. @@ -403,18 +415,15 @@ withLedgerPeers :: forall peerAddr resolver exception m a. , Exception exception , Ord peerAddr ) - => StdGen - -> DNSSemaphore m - -> (IP.IP -> Socket.PortNumber -> peerAddr) - -> Tracer m TraceLedgerPeers - -> STM m UseLedgerPeers - -> LedgerPeersConsensusInterface m - -> DNSActions resolver exception m - -> ( (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime))) + => PeerActionsDNS peerAddr resolver exception m + -> WithLedgerPeersArgs m + -> ((NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime))) -> Async m Void -> m a ) -> m a -withLedgerPeers inRng dnsSemaphore toPeerAddr tracer readUseLedgerPeers interface dnsActions k = do +withLedgerPeers PeerActionsDNS { paToPeerAddr = toPeerAddr, paDnsActions = dnsActions, paDnsSemaphore = dnsSemaphore } + WithLedgerPeersArgs { wlpRng = inRng, wlpConsensusInterface = interface, wlpTracer = tracer, wlpGetUseLedgerPeers = readUseLedgerPeers } + k = do reqVar <- newEmptyTMVarIO respVar <- newEmptyTMVarIO let getRequest = takeTMVar reqVar diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs index fd835c5b8c2..bf59795588d 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs @@ -11,6 +11,8 @@ module Ouroboros.Network.PeerSelection.PeerSelectionActions -- * Re-exports , PeerSelectionTargets (..) , PeerAdvertise (..) + , PeerSelectionActionsArgs (..) + , PeerSelectionActionsDiffusionMode (..) ) where @@ -29,7 +31,6 @@ import Data.Set (Set) import Data.Void (Void) import Network.DNS qualified as DNS -import Network.Socket qualified as Socket import Data.Bifunctor (first) import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..), @@ -41,15 +42,42 @@ import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSActions) -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore +import Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers import Ouroboros.Network.PeerSharing (PeerSharingController, requestPeers) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..)) -import System.Random (StdGen) +-- | Record of parameters for withPeerSelectionActions independent of diffusion mode +-- +data PeerSelectionActionsArgs peeraddr peerconn exception m = PeerSelectionActionsArgs { + psLocalRootPeersTracer :: Tracer m (TraceLocalRootPeers peeraddr exception), + psPublicRootPeersTracer :: Tracer m TracePublicRootPeers, + psReadTargets :: STM m PeerSelectionTargets, + -- ^ peer selection governor know, established and active targets + psJudgement :: STM m LedgerStateJudgement, + -- ^ are we there yet? + psReadLocalRootPeers :: STM m [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))], + psReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise), + psReadUseBootstrapPeers :: STM m UseBootstrapPeers, + psPeerSharing :: PeerSharing, + -- ^ peer sharing configured value + psPeerConnToPeerSharing :: peerconn -> PeerSharing, + -- ^ Extract peer sharing information from peerconn + psReadPeerSharingController :: STM m (Map peeraddr (PeerSharingController peeraddr m)) + -- ^ peer sharing registry + } + +-- | Record of remaining parameters for withPeerSelectionActions +-- that were extracted out since the following vary based on the diffusion mode +-- +data PeerSelectionActionsDiffusionMode peeraddr peerhandle m = PeerSelectionActionsDiffusionMode { + psNewInboundConnections :: STM m (peeraddr, PeerSharing), + -- ^ Read New Inbound Connections + psPeerStateActions :: PeerStateActions peeraddr peerhandle m + -- ^ callbacks for peer state changes + } withPeerSelectionActions :: forall peeraddr peerconn resolver exception m a. @@ -61,36 +89,10 @@ withPeerSelectionActions , Ord peeraddr , Exception exception ) - => Tracer m (TraceLocalRootPeers peeraddr exception) - -> Tracer m TracePublicRootPeers - -> Tracer m TraceLedgerPeers - -> (IP -> Socket.PortNumber -> peeraddr) - -> DNSActions resolver exception m - -> STM m PeerSelectionTargets - -> STM m LedgerStateJudgement - -> STM m [( HotValency - , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] - -- ^ local root peers - -> STM m (Map RelayAccessPoint PeerAdvertise) - -- ^ public root peers - -> STM m UseBootstrapPeers - -- ^ bootstrap peers - -> PeerSharing - -- ^ peer sharing configured value - -> (peerconn -> PeerSharing) - -- ^ Extract peer sharing information from peerconn - -> STM m (Map peeraddr (PeerSharingController peeraddr m)) - -- ^ peer sharing registry - -> STM m (peeraddr, PeerSharing) - -- ^ Read New Inbound Connections - -> PeerStateActions peeraddr peerconn m - -> StdGen - -- ^ Random generator for picking ledger peers - -> LedgerPeersConsensusInterface m - -- ^ Get Ledger Peers comes from here - -> STM m UseLedgerPeers - -- ^ Get Use Ledger After value + => PeerActionsDNS peeraddr resolver exception m + -> PeerSelectionActionsArgs peeraddr peerconn exception m + -> WithLedgerPeersArgs m + -> PeerSelectionActionsDiffusionMode peeraddr peerconn m -> ( (Async m Void, Async m Void) -> PeerSelectionActions peeraddr peerconn m -> m a) @@ -98,56 +100,49 @@ withPeerSelectionActions -- (only if local root peers were non-empty). -> m a withPeerSelectionActions - localRootTracer - publicRootTracer - ledgerPeersTracer - toPeerAddr - dnsActions - readPeerSelectionTargets - readLedgerStateJudgement - readLocalRootPeers - readPublicRootPeers - readUseBootstrapPeers - peerSharing - peerConnToPeerSharing - readPeerSharingController - readNewInboundConnections - peerStateActions - ledgerPeersRng - ledgerPeersConsensusInterface - getUseLedgerPeers + paDNS@PeerActionsDNS { paToPeerAddr = toPeerAddr, paDnsActions = dnsActions, paDnsSemaphore = dnsSemaphore } + PeerSelectionActionsArgs { + psLocalRootPeersTracer = localTracer, + psPublicRootPeersTracer = publicTracer, + psReadTargets = selectionTargets, + psJudgement = judgement, + psReadLocalRootPeers = localRootPeers, + psReadPublicRootPeers = publicRootPeers, + psReadUseBootstrapPeers = useBootstrapped, + psPeerSharing = sharing, + psPeerConnToPeerSharing = peerConnToPeerSharing, + psReadPeerSharingController = sharingController } + ledgerPeersArgs + PeerSelectionActionsDiffusionMode { psNewInboundConnections = readNewInboundConnections, psPeerStateActions = peerStateActions } k = do localRootsVar <- newTVarIO mempty - dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore - withLedgerPeers ledgerPeersRng dnsSemaphore toPeerAddr ledgerPeersTracer getUseLedgerPeers - ledgerPeersConsensusInterface dnsActions + withLedgerPeers + paDNS + ledgerPeersArgs (\getLedgerPeers lpThread -> do let peerSelectionActions = PeerSelectionActions { - readPeerSelectionTargets, - readLocalRootPeers = readTVar localRootsVar, - readNewInboundConnection = readNewInboundConnections, - peerSharing, - peerConnToPeerSharing, - requestPublicRootPeers = - \lpk n -> requestPublicRootPeers lpk n getLedgerPeers dnsSemaphore, - requestPeerShare, - peerStateActions, - readLedgerStateJudgement, - readUseBootstrapPeers - } + readPeerSelectionTargets = selectionTargets, + readLocalRootPeers = readTVar localRootsVar, + readNewInboundConnection = readNewInboundConnections, + peerSharing = sharing, + peerConnToPeerSharing = peerConnToPeerSharing, + requestPublicRootPeers = \lpk n -> requestPublicRootPeers lpk n getLedgerPeers, + requestPeerShare, + peerStateActions, + readUseBootstrapPeers = useBootstrapped, + readLedgerStateJudgement = judgement } withAsync (localRootPeersProvider - localRootTracer + localTracer toPeerAddr -- NOTE: we don't set `resolvConcurrent` because -- of https://github.com/kazu-yamamoto/dns/issues/174 DNS.defaultResolvConf dnsActions - readLocalRootPeers + localRootPeers localRootsVar) - (\lrppThread -> k (lpThread, lrppThread) peerSelectionActions) - ) + (\lrppThread -> k (lpThread, lrppThread) peerSelectionActions)) where -- We start by reading the current ledger state judgement, if it is -- YoungEnough we only care about fetching for ledger peers, otherwise we @@ -156,17 +151,16 @@ withPeerSelectionActions :: LedgerPeersKind -> Int -> (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime))) - -> DNSSemaphore m -> m (PublicRootPeers peeraddr, DiffTime) - requestPublicRootPeers ledgerPeersKind n getLedgerPeers dnsSemaphore = do + requestPublicRootPeers ledgerPeersKind n getLedgerPeers = do -- Check if the node is in a sensitive state usingBootstrapPeers <- atomically - $ requiresBootstrapPeers <$> readUseBootstrapPeers - <*> readLedgerStateJudgement + $ requiresBootstrapPeers <$> useBootstrapped + <*> judgement if usingBootstrapPeers then do -- If the ledger state is in sensitive state we should get trustable peers. - (bootstrapPeers, dt) <- requestConfiguredBootstrapPeers dnsSemaphore n + (bootstrapPeers, dt) <- requestConfiguredBootstrapPeers n pure (PublicRootPeers.fromBootstrapPeers bootstrapPeers, dt) else do -- If the ledger state is not in a sensitive state we should get ledger @@ -176,8 +170,8 @@ withPeerSelectionActions case mbLedgerPeers of -- no peers from the ledger Nothing -> do - (publicRootPeers, dt) <- requestConfiguredPublicRootPeers dnsSemaphore n - pure (PublicRootPeers.fromPublicRootPeers publicRootPeers, dt) + (publicRootPeers', dt) <- requestConfiguredPublicRootPeers n + pure (PublicRootPeers.fromPublicRootPeers publicRootPeers', dt) Just (ledgerPeers, dt) -> case ledgerPeersKind of AllLedgerPeers -> @@ -188,31 +182,31 @@ withPeerSelectionActions -- For each call we re-initialise the dns library which forces reading -- `/etc/resolv.conf`: -- https://github.com/intersectmbo/cardano-node/issues/731 - requestConfiguredPublicRootPeers :: DNSSemaphore m -> Int -> m (Map peeraddr PeerAdvertise, DiffTime) - requestConfiguredPublicRootPeers dnsSemaphore n = + requestConfiguredPublicRootPeers :: Int -> m (Map peeraddr PeerAdvertise, DiffTime) + requestConfiguredPublicRootPeers n = -- NOTE: we don't set `resolvConcurrent` because of -- https://github.com/kazu-yamamoto/dns/issues/174 - publicRootPeersProvider publicRootTracer + publicRootPeersProvider publicTracer toPeerAddr dnsSemaphore -- NOTE: we don't set `resolveConcurrent` because -- of https://github.com/kazu-yamamoto/dns/issues/174 DNS.defaultResolvConf - readPublicRootPeers + publicRootPeers dnsActions ($ n) - requestConfiguredBootstrapPeers :: DNSSemaphore m -> Int -> m (Set peeraddr, DiffTime) - requestConfiguredBootstrapPeers dnsSemaphore n = do + requestConfiguredBootstrapPeers :: Int -> m (Set peeraddr, DiffTime) + requestConfiguredBootstrapPeers n = do let readBootstrapPeersMap = fmap (\case DontUseBootstrapPeers -> Map.empty UseBootstrapPeers domains -> Map.fromList ((,DoNotAdvertisePeer) <$> domains) ) - readUseBootstrapPeers + useBootstrapped - publicRootPeersProvider publicRootTracer + publicRootPeersProvider publicTracer toPeerAddr dnsSemaphore DNS.defaultResolvConf @@ -222,7 +216,7 @@ withPeerSelectionActions requestPeerShare :: PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr) requestPeerShare amount peer = do - controllerMap <- atomically readPeerSharingController + controllerMap <- atomically sharingController case Map.lookup peer controllerMap of -- Peer Registering happens asynchronously with respect to -- requestPeerShare. This means that there's a possible race where the diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs new file mode 100644 index 00000000000..db5899a22f6 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -0,0 +1,18 @@ +module Ouroboros.Network.PeerSelection.RootPeersDNS + ( module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + , PeerActionsDNS (..) + ) where + +import Data.IP (IP) +import Network.Socket (PortNumber) + +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + +-- | Record of some parameters that are commonly used together +-- +data PeerActionsDNS peeraddr resolver exception m = PeerActionsDNS { + paToPeerAddr :: IP -> PortNumber -> peeraddr, + paDnsActions :: DNSActions resolver exception m, + paDnsSemaphore :: DNSSemaphore m + } From b4f086ad2fb1ddc5f5bea7fb59c7d05aafd35844 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= <158484752+crocodile-dentist@users.noreply.github.com> Date: Tue, 20 Feb 2024 11:55:49 +0100 Subject: [PATCH 2/2] Update ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs Co-authored-by: Marcin Szamotulski --- .../src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs index bf59795588d..fd5fa8eed16 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs @@ -57,7 +57,7 @@ data PeerSelectionActionsArgs peeraddr peerconn exception m = PeerSelectionActio psReadTargets :: STM m PeerSelectionTargets, -- ^ peer selection governor know, established and active targets psJudgement :: STM m LedgerStateJudgement, - -- ^ are we there yet? + -- ^ Is consensus close to current slot? psReadLocalRootPeers :: STM m [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))], psReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise), psReadUseBootstrapPeers :: STM m UseBootstrapPeers,