From 202ab34fa83c040df72eed24b82a7819ee3beed7 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Fri, 14 Jul 2023 17:53:26 +0100 Subject: [PATCH] Refactor PeerSelection.RootPeersDNS - Refactor `withLedgerPeers` & `resolveDomainAccessPoint` - Removes `withLedgerPeers` (only used in tests now) - `withPeerSelectionActions` is responsible for fetching and resolving all peers - Renames `resolveDomainAccessPoint` to `resolveLedgerPeers` - Splits `Ouroboros.Network.PeerSelection.RootPeersDNS` into - `Ouroboros.Network.PeerSelection.DNS.RootPeers` - `Ouroboros.Network.PeerSelection.DNS.LocalRoots` - `Ouroboros.Network.PeerSelection.DNS.LedgerPeers` - `Ouroboros.Network.PeerSelection.DNS.DNSSemaphore` --- ouroboros-network/CHANGELOG.md | 5 + ouroboros-network/ouroboros-network.cabal | 6 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 20 +- .../Network/Diffusion/Node/MiniProtocols.hs | 4 +- .../Test/Ouroboros/Network/LedgerPeers.hs | 85 +++-- .../Test/Ouroboros/Network/PeerSelection.hs | 14 +- .../Network/PeerSelection/Instances.hs | 7 +- .../Ouroboros/Network/PeerSelection/Json.hs | 4 +- .../Network/PeerSelection/KnownPeers.hs | 6 +- .../Network/PeerSelection/MockEnvironment.hs | 6 +- .../Network/PeerSelection/RootPeersDNS.hs | 67 ++-- .../Test/Ouroboros/Network/Testnet.hs | 5 +- .../Network/Testnet/Simulation/Node.hs | 26 +- .../src/Ouroboros/Network/Diffusion/Common.hs | 9 +- .../src/Ouroboros/Network/Diffusion/P2P.hs | 210 +++++------ .../src/Ouroboros/Network/NodeToNode.hs | 3 - .../PeerSelection/Governor/ActivePeers.hs | 2 +- .../PeerSelection/Governor/BigLedgerPeers.hs | 3 +- .../Governor/EstablishedPeers.hs | 2 +- .../Network/PeerSelection/Governor/Types.hs | 6 +- .../PeerSelection/PeerSelectionActions.hs | 97 +++-- .../PeerSelection/RootPeersDNS/DNSActions.hs | 14 +- .../RootPeersDNS/DNSSemaphore.hs | 45 +++ .../{ => RootPeersDNS}/LedgerPeers.hs | 248 ++++++++---- .../LocalRootPeers.hs} | 354 +++--------------- .../RootPeersDNS/PublicRootPeers.hs | 158 ++++++++ .../Network/PeerSelection/State/KnownPeers.hs | 3 +- 27 files changed, 772 insertions(+), 637 deletions(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSSemaphore.hs rename ouroboros-network/src/Ouroboros/Network/PeerSelection/{ => RootPeersDNS}/LedgerPeers.hs (70%) rename ouroboros-network/src/Ouroboros/Network/PeerSelection/{RootPeersDNS.hs => RootPeersDNS/LocalRootPeers.hs} (52%) create mode 100644 ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/PublicRootPeers.hs diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 966e498f10b..51a38565fa5 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -4,6 +4,11 @@ ### Breaking changes +* Refactors `PeerSelection.RootPeersDNS` module, enabling more sharing between + modules and providing just better module organisation overall. + * Tweaks exports and imports + * Shares semaphores with `withPeerSelectionActions` and `ledgerPeersThread` + ### Non-breaking changes * Less aggresive churning of established and known peers. diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 9e378b86dbf..cefd3392374 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -46,12 +46,14 @@ library Ouroboros.Network.NodeToClient Ouroboros.Network.Tracers Ouroboros.Network.PeerSelection.Types - Ouroboros.Network.PeerSelection.LedgerPeers Ouroboros.Network.PeerSelection.PeerMetric Ouroboros.Network.PeerSelection.PeerSelectionActions Ouroboros.Network.PeerSelection.PeerStateActions Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions - Ouroboros.Network.PeerSelection.RootPeersDNS + Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers Ouroboros.Network.PeerSelection.Governor Ouroboros.Network.PeerSelection.State.EstablishedPeers Ouroboros.Network.PeerSelection.State.KnownPeers diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node.hs index 98d892567bb..ff08d9c8dad 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node.hs @@ -3,7 +3,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -22,11 +21,8 @@ module Test.Ouroboros.Network.Diffusion.Node -- * extra types used by the node , AcceptedConnectionsLimit (..) , DiffusionMode (..) - , LedgerPeersConsensusInterface (..) , PeerAdvertise (..) , PeerSelectionTargets (..) - , RelayAccessPoint (..) - , UseLedgerAfter (..) -- * configuration constants , config_RECONNECT_DELAY ) where @@ -79,13 +75,8 @@ import Ouroboros.Network.ExitPolicy (ReconnectDelay (..)) import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.Governor (PeerSelectionTargets (..)) -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface (..), UseLedgerAfter (..)) import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetricsConfiguration (..), newPeerMetric) -import Ouroboros.Network.PeerSelection.RootPeersDNS - (DomainAccessPoint (..), LookupReqs (..), - RelayAccessPoint (..), newLocalAndPublicRootDNSSemaphore) import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec (VersionDataCodec (..), noTimeLimitsHandshake, @@ -108,6 +99,12 @@ import Simulation.Network.Snocket (AddressType (..), FD) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (DomainAccessPoint, RelayAccessPoint) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + (DNSLookupType) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (LedgerPeersConsensusInterface, UseLedgerAfter) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) import Ouroboros.Network.PeerSharing @@ -127,7 +124,7 @@ data Interfaces m = Interfaces { iNtnSnocket :: Snocket m (NtNFD m) NtNAddr , iNtnBearer :: MakeBearer m (NtNFD m) , iAcceptVersion :: NtNVersionData -> NtNVersionData -> Accept NtNVersionData - , iNtnDomainResolver :: LookupReqs -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr)) + , iNtnDomainResolver :: DNSLookupType -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr)) , iNtcSnocket :: Snocket m (NtCFD m) NtCAddr , iNtcBearer :: MakeBearer m (NtCFD m) , iRng :: StdGen @@ -203,7 +200,6 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- LazySTM.newTVarIO (aDNSTimeoutScript na) dnsLookupDelayScriptVar <- LazySTM.newTVarIO (aDNSLookupDelayScript na) - dnsSemaphore <- newLocalAndPublicRootDNSSemaphore peerMetrics <- newPeerMetric PeerMetricsConfiguration { maxEntriesToTrack = 180 } peerSharingRegistry <- PeerSharingRegistry <$> newTVarIO mempty @@ -235,7 +231,6 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = InitiatorAndResponderDiffusionMode -> Duplex , Diff.P2P.diNtnPeerSharing = ntnPeerSharing , Diff.P2P.diNtnToPeerAddr = \a b -> TestAddress (Node.IPAddr a b) - , Diff.P2P.diNtnDomainResolver = iNtnDomainResolver ni , Diff.P2P.diNtcSnocket = iNtcSnocket ni , Diff.P2P.diNtcBearer = iNtcBearer ni , Diff.P2P.diNtcHandshakeArguments = @@ -254,7 +249,6 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = (iDomainMap ni) dnsTimeoutScriptVar dnsLookupDelayScriptVar) - , Diff.P2P.diLocalAndPublicRootDnsSemaphore = dnsSemaphore } appsExtra :: Diff.P2P.ApplicationsExtra NtNAddr m () diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index 354480df28f..4f808705596 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -77,8 +77,6 @@ import qualified Ouroboros.Network.Mock.Chain as Chain import Ouroboros.Network.Mock.ProducerState import Ouroboros.Network.Mux import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface) import Ouroboros.Network.Util.ShowProxy import Ouroboros.Network.Mock.ConcreteBlock @@ -91,6 +89,8 @@ import Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum, chainSyncMiniProtocolNum, keepAliveMiniProtocolNum, peerSharingMiniProtocolNum) import qualified Ouroboros.Network.PeerSelection.PeerSharing as PSTypes +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (LedgerPeersConsensusInterface) import Ouroboros.Network.PeerSharing (bracketPeerSharingClient, peerSharingClient, peerSharingServer) import Ouroboros.Network.Protocol.PeerSharing.Client diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/LedgerPeers.hs index eea68d78215..9c29149af22 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/LedgerPeers.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/LedgerPeers.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Test.Ouroboros.Network.LedgerPeers where @@ -21,7 +23,6 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) import Data.Monoid (Sum (..)) import Data.Ord (Down (..)) import Data.Ratio @@ -31,9 +32,24 @@ import Data.Word import System.Random import Network.DNS (Domain) -import Network.Socket (SockAddr) -import Ouroboros.Network.PeerSelection.LedgerPeers - +import Network.Socket (PortNumber) + +import Control.Concurrent.Class.MonadSTM.Strict +import Data.IP (IP) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (AccPoolStake (..), PoolStake (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (RelayAccessPoint (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (LedgerPeersConsensusInterface (..), LedgerPeersKind (..), + NumberOfPeers (..), UseLedgerAfter (..), accBigPoolStake, + accPoolStake, bigLedgerPeerQuota, withLedgerPeers) +import Ouroboros.Network.Testing.Data.Script (Script (..), + initScript', stepScript') +import Test.Ouroboros.Network.PeerSelection.RootPeersDNS + (DNSLookupDelay, DNSTimeout (..), + DelayAndTimeoutScripts (..), MockRoots (..), + mockDNSActions) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -124,8 +140,11 @@ instance Arbitrary ArbLedgerPeersKind where prop_pick100 :: Word16 -> NonNegative Int -- ^ number of pools with 0 stake -> ArbLedgerPeersKind + -> MockRoots + -> DelayAndTimeoutScripts -> Property -prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) = +prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoots _ dnsMapScript _ _) + (DelayAndTimeoutScripts dnsLookupDelayScript dnsTimeoutScript) = let rng = mkStdGen $ fromIntegral seed sps = [ (0, RelayAccessAddress (read $ "0.0.0." ++ show a) 1 :| []) | a <- [0..n] @@ -137,11 +156,19 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) = BigLedgerPeers -> accBigPoolStake sps sim :: IOSim s [RelayAccessPoint] - sim = withLedgerPeers + sim = do + dnsMapScriptVar <- initScript' dnsMapScript + dnsMap <- stepScript' dnsMapScriptVar + dnsMapVar <- newTVarIO dnsMap + + dnsTimeoutScriptVar <- initScript' dnsTimeoutScript + dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript + + withLedgerPeers rng (curry IP.toSockAddr) verboseTracer (pure (UseLedgerAfter 0)) interface - (\_ -> pure Map.empty) -- we're not relying on domain name resolution in this simulation + (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar) (\request _ -> do threadDelay 1900 -- we need to invalidate ledger peer's cache resp <- request (NumberOfPeers 1) ledgerPeersKind @@ -173,15 +200,26 @@ prop_pick :: LedgerPools -> ArbLedgerPeersKind -> Word16 -> Word16 + -> MockRoots + -> Script DNSLookupDelay -> Property -prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed = +prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed (MockRoots _ dnsMapScript _ _) + dnsLookupDelayScript = let rng = mkStdGen $ fromIntegral seed sim :: IOSim s [RelayAccessPoint] - sim = withLedgerPeers + sim = do + dnsMapScriptVar <- initScript' dnsMapScript + dnsMap <- stepScript' dnsMapScriptVar + dnsMapVar <- newTVarIO dnsMap + + dnsTimeoutScriptVar <- initScript' (Script (DNSTimeout 0 :| [])) + dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript + withLedgerPeers rng (curry IP.toSockAddr) verboseTracer (pure (UseLedgerAfter 0)) - interface resolve + interface + (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar) (\request _ -> do threadDelay 1900 -- we need to invalidate ledger peer's cache resp <- request (NumberOfPeers count) ledgerPeersKind @@ -198,17 +236,6 @@ prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed = domainMap :: Map Domain (Set IP) domainMap = Map.fromList [("relay.iohk.example", Set.singleton (read "2.2.2.2"))] - resolve :: [DomainAccessPoint] - -> IOSim s (Map DomainAccessPoint (Set SockAddr)) - resolve = \daps -> - pure $ Map.fromList - [ (dap, addrs) - | dap@(DomainAccessPoint domain port) <- daps - , let addrs = Set.map (\ip -> IP.toSockAddr (ip, port)) - . fromMaybe Set.empty - $ Map.lookup domain domainMap - ] - reverseLookup :: RelayAccessPoint -> RelayAccessPoint reverseLookup ap@(RelayAccessAddress ip port) = case [ domain @@ -270,12 +297,6 @@ prop_accBigPoolStake (LedgerPools lps@(_:_)) = where accumulatedStakeMap = accBigPoolStake lps -prop :: Property -prop = prop_pick (LedgerPools [( PoolStake {unPoolStake = 1 % 1} - , RelayAccessAddress (read "1.1.1.1") 1016 :| [] - )]) - (ArbLedgerPeersKind BigLedgerPeers) 0 2 - -- TODO: Belongs in iosim. data SimResult a = SimReturn a [String] | SimException SomeException [String] diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection.hs index 1ede66baaf6..60a6380cf8f 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection.hs @@ -52,7 +52,6 @@ import Network.Socket (SockAddr) import Ouroboros.Network.PeerSelection.Governor hiding (PeerSelectionState (..), peerSharing) import qualified Ouroboros.Network.PeerSelection.Governor as Governor -import Ouroboros.Network.PeerSelection.RootPeersDNS import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers @@ -71,10 +70,19 @@ import Test.Ouroboros.Network.PeerSelection.PeerGraph import Control.Concurrent.Class.MonadSTM.Strict (newTVarIO) import Control.Monad.Class.MonadTime.SI import Control.Monad.IOSim -import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (RelayAccessPoint) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + (DNSLookupType (..), ioDNSActions) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + (newLedgerAndPublicRootDNSSemaphore) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (IsLedgerPeer (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + (publicRootPeersProvider) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), LocalRootPeers, WarmValency (..)) import Ouroboros.Network.Protocol.PeerSharing.Type @@ -2855,7 +2863,7 @@ _governorFindingPublicRoots :: Int -> PeerSharing -> IO Void _governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = do - dnsSemaphore <- newLocalAndPublicRootDNSSemaphore + dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore publicRootPeersProvider tracer (curry IP.toSockAddr) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Instances.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Instances.hs index 3af30b5e6a6..fd9c350b930 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Instances.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Instances.hs @@ -18,14 +18,15 @@ import Data.Text.Encoding (encodeUtf8) import Data.Word (Word32) import Ouroboros.Network.PeerSelection.Governor -import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..)) -import Ouroboros.Network.PeerSelection.RootPeersDNS - (DomainAccessPoint (..), RelayAccessPoint (..)) import qualified Data.IP as IP import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (DomainAccessPoint (..), RelayAccessPoint (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (IsLedgerPeer (..)) import Ouroboros.Network.Testing.Utils (prop_shrink_nonequal, prop_shrink_valid) import Test.QuickCheck diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Json.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Json.hs index 48e8d98f5c3..6c3dc26d90c 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Json.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Json.hs @@ -1,11 +1,11 @@ module Test.Ouroboros.Network.PeerSelection.Json (tests) where import Data.Aeson (decode, encode, fromJSON, toJSON) -import Ouroboros.Network.PeerSelection.RootPeersDNS - (DomainAccessPoint (..), RelayAccessPoint (..)) import Test.Ouroboros.Network.PeerSelection.Instances () import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (DomainAccessPoint, RelayAccessPoint) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs index 502bb1dddb3..c71493c1f7d 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs @@ -1,10 +1,12 @@ module Test.Ouroboros.Network.PeerSelection.KnownPeers (tests) where import Data.Map (Map) -import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer, - RelayAccessPoint) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (RelayAccessPoint) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (IsLedgerPeer) import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import Test.Ouroboros.Network.PeerSelection.Instances () import Test.QuickCheck (Property, counterexample) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs index 10a6635877b..b8199b985a0 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs @@ -71,10 +71,12 @@ import Test.Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRoo import Test.Ouroboros.Network.PeerSelection.PeerGraph import Test.Ouroboros.Network.ShrinkCarefully -import Ouroboros.Network.PeerSelection.LedgerPeers (IsBigLedgerPeer, - IsLedgerPeer) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (IsBigLedgerPeer) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (IsLedgerPeer) import Ouroboros.Network.PeerSelection.Types (PeerStatus (..)) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount, PeerSharingResult (..)) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs index 9d74c273347..ead079b5fb7 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -11,19 +11,19 @@ module Test.Ouroboros.Network.PeerSelection.RootPeersDNS ( tests , mockDNSActions + , MockRoots (..) , DNSTimeout (..) , DNSLookupDelay (..) + , DelayAndTimeoutScripts (..) ) where -import Ouroboros.Network.PeerSelection.RootPeersDNS - import Control.Applicative (Alternative) import Control.Monad (forever, replicateM_) import Data.ByteString.Char8 (pack) import Data.Dynamic (Typeable, fromDynamic) import Data.Foldable (foldl') import Data.Functor (void) -import Data.IP (fromHostAddress, toIPv4w, toSockAddr) +import Data.IP (IP (..), fromHostAddress, toIPv4w, toSockAddr) import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -32,7 +32,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Time.Clock (picosecondsToDiffTime) import Data.Void (Void) -import Network.DNS (DNSError (NameError, TimeoutExpired)) +import Network.DNS (DNSError (NameError, TimeoutExpired), Domain, TTL) import qualified Network.DNS.Resolver as DNSResolver import Network.Socket (SockAddr (..)) @@ -50,6 +50,18 @@ import Control.Tracer (Tracer (Tracer), contramap) import Data.List (intercalate) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (DomainAccessPoint (..), RelayAccessPoint (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + (DNSActions (..), constantResource) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + (newLedgerAndPublicRootDNSSemaphore) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (TraceLedgerPeers, resolveLedgerPeers) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + (TraceLocalRootPeers (..), localRootPeersProvider) +import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + (TracePublicRootPeers (..), publicRootPeersProvider) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..)) import Ouroboros.Network.Testing.Data.Script (NonEmpty ((:|)), @@ -392,7 +404,7 @@ mockPublicRootPeersProvider tracer (MockRoots _ _ publicRootPeers dnsMapScript) dnsMapScriptVar <- initScript' dnsMapScript dnsMap <- stepScript' dnsMapScriptVar dnsMapVar <- newTVarIO dnsMap - dnsSemaphore <- newLocalAndPublicRootDNSSemaphore + dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore dnsTimeoutScriptVar <- initScript' dnsTimeoutScript dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript @@ -414,34 +426,35 @@ mockPublicRootPeersProvider tracer (MockRoots _ _ publicRootPeers dnsMapScript) -- | 'resolveDomainAddresses' running with a given MockRoots env -- -mockResolveDomainAddresses :: ( MonadAsync m - , MonadDelay m - , MonadThrow m - , MonadTimer m - ) - => Tracer m TracePublicRootPeers - -> MockRoots - -> Script DNSTimeout - -> Script DNSLookupDelay - -> m (Map DomainAccessPoint (Set SockAddr)) -mockResolveDomainAddresses tracer (MockRoots _ _ publicRootPeers dnsMapScript) - dnsTimeoutScript dnsLookupDelayScript = do +mockResolveLedgerPeers :: ( MonadAsync m + , MonadDelay m + , MonadThrow m + , MonadTimer m + ) + => Tracer m TraceLedgerPeers + -> MockRoots + -> Script DNSTimeout + -> Script DNSLookupDelay + -> m (Map DomainAccessPoint (Set SockAddr)) +mockResolveLedgerPeers tracer (MockRoots _ _ publicRootPeers dnsMapScript) + dnsTimeoutScript dnsLookupDelayScript = do dnsMapScriptVar <- initScript' dnsMapScript dnsMap <- stepScript' dnsMapScriptVar dnsMapVar <- newTVarIO dnsMap - dnsSemaphore <- newLocalAndPublicRootDNSSemaphore + dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore dnsTimeoutScriptVar <- initScript' dnsTimeoutScript dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript - resolveDomainAccessPoint tracer - dnsSemaphore - DNSResolver.defaultResolvConf - (mockDNSActions @Failure dnsMapVar - dnsTimeoutScriptVar - dnsLookupDelayScriptVar) - [ domain - | (RelayDomainAccessPoint domain, _) - <- Map.assocs publicRootPeers ] + resolveLedgerPeers tracer + (curry toSockAddr) + dnsSemaphore + DNSResolver.defaultResolvConf + (mockDNSActions @Failure dnsMapVar + dnsTimeoutScriptVar + dnsLookupDelayScriptVar) + [ domain + | (RelayDomainAccessPoint domain, _) + <- Map.assocs publicRootPeers ] -- -- Utils for properties diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet.hs index c80d9412612..0d87367e7d1 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet.hs @@ -45,7 +45,6 @@ import Ouroboros.Network.PeerSelection.Governor hiding (PeerSelectionState (..)) import qualified Ouroboros.Network.PeerSelection.Governor as Governor import Ouroboros.Network.PeerSelection.PeerStateActions -import Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers @@ -86,6 +85,10 @@ import Ouroboros.Network.NodeToNode (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (DomainAccessPoint (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + (TraceLocalRootPeers (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..)) import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..)) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet/Simulation/Node.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet/Simulation/Node.hs index 8ce3e62e52c..7e1e6dc0d68 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet/Simulation/Node.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet/Simulation/Node.hs @@ -80,15 +80,8 @@ import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), PeerSelectionTargets (..), TracePeerSelection) import qualified Ouroboros.Network.PeerSelection.Governor as PeerSelection -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface (..), UseLedgerAfter (..), - accPoolStake) import Ouroboros.Network.PeerSelection.PeerStateActions (PeerSelectionActionsTrace) -import Ouroboros.Network.PeerSelection.RootPeersDNS - (DomainAccessPoint (..), LookupReqs (..), PortNumber, - RelayAccessPoint (..), TraceLocalRootPeers, - TracePublicRootPeers) import Ouroboros.Network.Protocol.BlockFetch.Codec (byteLimitsBlockFetch, timeLimitsBlockFetch) import Ouroboros.Network.Protocol.ChainSync.Codec @@ -129,6 +122,17 @@ import Ouroboros.Network.BlockFetch (TraceFetchClientState, import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (DomainAccessPoint (..), PortNumber, RelayAccessPoint (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + (DNSLookupType) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (LedgerPeersConsensusInterface (..), TraceLedgerPeers, + UseLedgerAfter (..), accPoolStake) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + (TraceLocalRootPeers) +import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + (TracePublicRootPeers) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..)) import Ouroboros.Network.Protocol.PeerSharing.Codec @@ -885,6 +889,7 @@ data DiffusionSimulationTrace data DiffusionTestTrace = DiffusionLocalRootPeerTrace (TraceLocalRootPeers NtNAddr SomeException) | DiffusionPublicRootPeerTrace TracePublicRootPeers + | DiffusionLedgerPeersTrace TraceLedgerPeers | DiffusionPeerSelectionTrace (TracePeerSelection NtNAddr) | DiffusionPeerSelectionActionsTrace (PeerSelectionActionsTrace NtNAddr NtNVersion) | DiffusionDebugPeerSelectionTrace (DebugPeerSelection NtNAddr) @@ -1176,7 +1181,7 @@ diffusionSimulation $ nodeTracer) domainResolver :: StrictTVar m (Map Domain [(IP, TTL)]) - -> LookupReqs + -> DNSLookupType -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr)) -- TODO: we can take into account the `LookupReqs` and return only `IPv4` @@ -1214,6 +1219,11 @@ diffusionSimulation . tracerWithName ntnAddr . tracerWithTime $ nodeTracer + , Diff.P2P.dtTraceLedgerPeersTracer = contramap + DiffusionLedgerPeersTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer , Diff.P2P.dtTracePeerSelectionTracer = contramap DiffusionPeerSelectionTrace . tracerWithName ntnAddr diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs index b66b1955699..5a6f480adfd 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs @@ -30,8 +30,8 @@ import qualified Ouroboros.Network.NodeToClient as NodeToClient import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit, ConnectionId, DiffusionMode) import qualified Ouroboros.Network.NodeToNode as NodeToNode -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface, TraceLedgerPeers) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (LedgerPeersConsensusInterface) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount) import Ouroboros.Network.Snocket (FileDescriptor) import Ouroboros.Network.Socket (SystemdSocketTracer) @@ -101,10 +101,6 @@ data Tracers ntnAddr ntnVersion ntcAddr ntcVersion m = Tracers { -- | Diffusion initialisation tracer , dtDiffusionTracer :: Tracer m (DiffusionTracer ntnAddr ntcAddr) - - -- | Ledger Peers tracer - , dtLedgerPeersTracer - :: Tracer m TraceLedgerPeers } @@ -118,7 +114,6 @@ nullTracers = Tracers { , dtLocalMuxTracer = nullTracer , dtLocalHandshakeTracer = nullTracer , dtDiffusionTracer = nullTracer - , dtLedgerPeersTracer = nullTracer } -- | Common DiffusionArguments interface between P2P and NonP2P diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs index b2c670758e9..56fc59f0255 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -6,6 +6,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} #if !defined(mingw32_HOST_OS) #define POSIX @@ -48,7 +49,7 @@ import qualified Data.IP as IP import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import Data.Maybe (catMaybes, maybeToList) -import Data.Set (Set, elemAt) +import Data.Set (elemAt) import Data.Typeable (Typeable) import Data.Void (Void) import System.Exit (ExitCode) @@ -57,7 +58,6 @@ import System.Random (StdGen, newStdGen, randomRs, split) import qualified System.Posix.Signals as Signals #endif -import qualified Network.DNS as DNS import Network.Socket (Socket) import qualified Network.Socket as Socket @@ -103,10 +103,9 @@ import qualified Ouroboros.Network.NodeToNode as NodeToNode import qualified Ouroboros.Network.PeerSelection.Governor as Governor import Ouroboros.Network.PeerSelection.Governor.Types (ChurnMode (ChurnModeNormal), DebugPeerSelection (..), - PeerSelectionCounters (..), PublicPeerSelectionState (..), + PeerSelectionActions, PeerSelectionCounters (..), + PeerStateActions, PublicPeerSelectionState (..), TracePeerSelection (..), emptyPublicPeerSelectionState) -import Ouroboros.Network.PeerSelection.LedgerPeers (LedgerPeersKind, - NumberOfPeers, UseLedgerAfter (..), withLedgerPeers) import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) import Ouroboros.Network.PeerSelection.PeerSelectionActions import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -114,12 +113,17 @@ import Ouroboros.Network.PeerSelection.PeerStateActions (PeerConnectionHandle, PeerSelectionActionsTrace (..), PeerStateActionsArguments (..), pchPeerSharing, withPeerStateActions) -import Ouroboros.Network.PeerSelection.RootPeersDNS (DNSActions, - DNSSemaphore, DomainAccessPoint, LookupReqs (..), - RelayAccessPoint (..), TraceLocalRootPeers (..), - TracePublicRootPeers (..), ioDNSActions, - newLocalAndPublicRootDNSSemaphore, - resolveDomainAccessPoint) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (RelayAccessPoint) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + (DNSActions, DNSLookupType (..), ioDNSActions) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (LedgerPeersConsensusInterface, TraceLedgerPeers, + UseLedgerAfter) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + (TraceLocalRootPeers) +import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + (TracePublicRootPeers) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) import Ouroboros.Network.PeerSharing (PeerSharingRegistry (..)) @@ -141,6 +145,10 @@ data TracersExtra ntnAddr ntnVersion ntnVersionData , dtTracePublicRootPeersTracer :: Tracer m TracePublicRootPeers + -- | Ledger Peers tracer + , dtTraceLedgerPeersTracer + :: Tracer m TraceLedgerPeers + , dtTracePeerSelectionTracer :: Tracer m (TracePeerSelection ntnAddr) @@ -205,6 +213,7 @@ nullTracers = TracersExtra { dtTraceLocalRootPeersTracer = nullTracer , dtTracePublicRootPeersTracer = nullTracer + , dtTraceLedgerPeersTracer = nullTracer , dtTracePeerSelectionTracer = nullTracer , dtDebugPeerSelectionInitiatorTracer = nullTracer , dtDebugPeerSelectionInitiatorResponderTracer = nullTracer @@ -456,11 +465,6 @@ data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData diNtnToPeerAddr :: IP -> Socket.PortNumber -> ntnAddr, - -- | node-to-node domain resolver - -- - diNtnDomainResolver - :: LookupReqs -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set ntnAddr)), - -- | node-to-client snocket -- diNtcSnocket @@ -497,12 +501,7 @@ data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData -- | diffusion dns actions -- diDnsActions - :: LookupReqs -> DNSActions resolver resolverError m, - - -- | DNS Semaphore - -- - diLocalAndPublicRootDnsSemaphore - :: DNSSemaphore m + :: DNSLookupType -> DNSActions resolver resolverError m } runM @@ -572,7 +571,6 @@ runM Interfaces , diNtnDataFlow , diNtnPeerSharing , diNtnToPeerAddr - , diNtnDomainResolver , diNtcSnocket , diNtcBearer , diNtcHandshakeArguments @@ -580,12 +578,10 @@ runM Interfaces , diRng , diInstallSigUSR1Handler , diDnsActions - , diLocalAndPublicRootDnsSemaphore } Tracers { dtMuxTracer , dtLocalMuxTracer - , dtLedgerPeersTracer , dtDiffusionTracer = tracer } TracersExtra @@ -596,6 +592,7 @@ runM Interfaces , dtPeerSelectionActionsTracer , dtTraceLocalRootPeersTracer , dtTracePublicRootPeersTracer + , dtTraceLedgerPeersTracer , dtConnectionManagerTracer , dtConnectionManagerTransitionTracer , dtServerTracer @@ -935,28 +932,34 @@ runM Interfaces let withPeerSelectionActions' :: forall muxMode responderCtx peerAddr bytes a1 b c. STM m (ntnAddr, PeerSharing) - -> Governor.PeerStateActions + -- ^ Read New Inbound Connections + -> PeerStateActions ntnAddr (PeerConnectionHandle muxMode responderCtx peerAddr ntnVersionData bytes m a1 b) m - -> (NumberOfPeers - -> LedgerPeersKind - -> m (Maybe (Set ntnAddr, DiffTime))) - -> (Async m Void - -> Governor.PeerSelectionActions + -> StdGen + -- ^ Random generator for picking ledger peers + -> LedgerPeersConsensusInterface m + -- ^ Get Ledger Peers comes from here + -> STM m UseLedgerAfter + -- ^ Get Use Ledger After value + -> ( (Async m Void, Async m Void) + -> PeerSelectionActions ntnAddr (PeerConnectionHandle muxMode responderCtx peerAddr ntnVersionData bytes m a1 b) m -> m c) + -- ^ continuation, receives a handle to the local roots peer provider thread + -- (only if local root peers were non-empty). -> m c withPeerSelectionActions' = withPeerSelectionActions dtTraceLocalRootPeersTracer dtTracePublicRootPeersTracer + dtTraceLedgerPeersTracer diNtnToPeerAddr - diLocalAndPublicRootDnsSemaphore (diDnsActions lookupReqs) (readTVar peerSelectionTargetsVar) daReadLocalRootPeers @@ -1031,73 +1034,72 @@ runM Interfaces -- -- Part (b): capturing the major control-flow of runM: -- - withLedgerPeers - ledgerPeersRng - diNtnToPeerAddr - dtLedgerPeersTracer - daReadUseLedgerAfter - daLedgerPeersCtx - (diNtnDomainResolver lookupReqs) - $ \requestLedgerPeers ledgerPeerThread -> - case diffusionMode of - - -- InitiatorOnly mode, run peer selection only: - InitiatorOnlyDiffusionMode -> - withConnectionManagerInitiatorOnlyMode $ \connectionManager-> do + case diffusionMode of + + -- InitiatorOnly mode, run peer selection only: + InitiatorOnlyDiffusionMode -> + withConnectionManagerInitiatorOnlyMode $ \connectionManager-> do + diInstallSigUSR1Handler connectionManager + withPeerStateActions' connectionManager $ \peerStateActions-> + withPeerSelectionActions' + retry + peerStateActions + ledgerPeersRng + daLedgerPeersCtx + daReadUseLedgerAfter + $ \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> + + Async.withAsync + (peerSelectionGovernor' + dtDebugPeerSelectionInitiatorTracer + 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 + inboundInfoChannel <- newInformationChannel + outboundInfoChannel <- newInformationChannel + observableStateVar <- Server.newObservableStateVar ntnInbgovRng + withConnectionManagerInitiatorAndResponderMode + inboundInfoChannel outboundInfoChannel + observableStateVar $ \connectionManager-> do diInstallSigUSR1Handler connectionManager withPeerStateActions' connectionManager $ \peerStateActions-> - withPeerSelectionActions' retry peerStateActions requestLedgerPeers - $ \localPeerSelectionActionsThread peerSelectionActions-> - - Async.withAsync - (peerSelectionGovernor' - dtDebugPeerSelectionInitiatorTracer - peerSelectionActions) - $ \governorThread -> - Async.withAsync peerChurnGovernor' $ \churnGovernorThread -> - -- wait for any thread to fail: - snd <$> Async.waitAny - [ localPeerSelectionActionsThread - , governorThread - , ledgerPeerThread - , churnGovernorThread - ] - - -- InitiatorAndResponder mode, run peer selection and the server: - InitiatorAndResponderDiffusionMode -> do - inboundInfoChannel <- newInformationChannel - outboundInfoChannel <- newInformationChannel - observableStateVar <- Server.newObservableStateVar ntnInbgovRng - withConnectionManagerInitiatorAndResponderMode - inboundInfoChannel outboundInfoChannel - observableStateVar $ \connectionManager-> do - diInstallSigUSR1Handler connectionManager - withPeerStateActions' connectionManager $ \peerStateActions-> - withPeerSelectionActions' - (readMessage outboundInfoChannel) - peerStateActions - requestLedgerPeers - $ \localPeerRootProviderThread peerSelectionActions-> - Async.withAsync - (peerSelectionGovernor' - dtDebugPeerSelectionInitiatorResponderTracer - 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 - [ localPeerRootProviderThread - , serverThread - , governorThread - , ledgerPeerThread - , churnGovernorThread - ] + withPeerSelectionActions' + (readMessage outboundInfoChannel) + peerStateActions + ledgerPeersRng + daLedgerPeersCtx + daReadUseLedgerAfter + $ \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> + Async.withAsync + (peerSelectionGovernor' + dtDebugPeerSelectionInitiatorResponderTracer + 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: -- @@ -1180,16 +1182,6 @@ run tracers tracersExtra args argsExtra apps appsExtra = do diInstallSigUSR1Handler = \_ -> pure () #endif - diLocalAndPublicRootDnsSemaphore <- newLocalAndPublicRootDNSSemaphore - let diNtnDomainResolver :: LookupReqs -> [DomainAccessPoint] - -> IO (Map DomainAccessPoint (Set Socket.SockAddr)) - diNtnDomainResolver lr = - resolveDomainAccessPoint - (dtTracePublicRootPeersTracer tracersExtra) - diLocalAndPublicRootDnsSemaphore - DNS.defaultResolvConf - (ioDNSActions lr) - diRng <- newStdGen runM Interfaces { @@ -1204,7 +1196,6 @@ run tracers tracersExtra args argsExtra apps appsExtra = do diNtnDataFlow = nodeDataFlow, diNtnPeerSharing = peerSharing, diNtnToPeerAddr = curry IP.toSockAddr, - diNtnDomainResolver, diNtcSnocket = Snocket.localSnocket iocp, diNtcBearer = makeLocalBearer, @@ -1213,8 +1204,7 @@ run tracers tracersExtra args argsExtra apps appsExtra = do diRng, diInstallSigUSR1Handler, - diDnsActions = ioDNSActions, - diLocalAndPublicRootDnsSemaphore + diDnsActions = ioDNSActions } tracers tracersExtra args argsExtra apps appsExtra diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 7292e5a3b90..4d73db9ef75 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -38,7 +38,6 @@ module Ouroboros.Network.NodeToNode , cleanNetworkMutableState , withServer -- * P2P Governor - , DomainAccessPoint (..) , PeerAdvertise (..) , PeerSelectionTargets (..) -- * Subscription Workers @@ -138,8 +137,6 @@ import Ouroboros.Network.PeerSelection.Governor.Types import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) -import Ouroboros.Network.PeerSelection.RootPeersDNS - (DomainAccessPoint (..)) import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version hiding (Accept) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs index 7619fa2ee58..41541461130 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs @@ -23,7 +23,7 @@ import Control.Monad.Class.MonadTimer.SI import System.Random (randomR) import Ouroboros.Network.PeerSelection.Governor.Types -import Ouroboros.Network.PeerSelection.LedgerPeers +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (IsBigLedgerPeer (..)) import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers (setTepidFlag) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/BigLedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/BigLedgerPeers.hs index 4e71837991b..d58ba503c3e 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/BigLedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/BigLedgerPeers.hs @@ -18,10 +18,11 @@ import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI import Ouroboros.Network.PeerSelection.Governor.Types -import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (IsLedgerPeer (..)) import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs index 6d78a921d3b..cc3ae28448f 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs @@ -21,7 +21,7 @@ import Control.Monad.Class.MonadTime.SI import System.Random (randomR) import Ouroboros.Network.PeerSelection.Governor.Types -import Ouroboros.Network.PeerSelection.LedgerPeers +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (IsBigLedgerPeer (..)) import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index e20d9a58644..d5829764bbc 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -60,10 +60,12 @@ import Control.Monad.Class.MonadTime.SI import System.Random (StdGen) import Ouroboros.Network.ExitPolicy -import Ouroboros.Network.PeerSelection.LedgerPeers (IsBigLedgerPeer, - IsLedgerPeer) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (IsBigLedgerPeer) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (IsLedgerPeer) import Ouroboros.Network.PeerSelection.State.EstablishedPeers (EstablishedPeers) import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs index 5a7262ac237..3d7c7595276 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs @@ -30,17 +30,31 @@ import Data.Void (Void) import qualified Network.DNS as DNS import qualified Network.Socket as Socket +import Data.IP (IP) import Ouroboros.Network.PeerSelection.Governor.Types -import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) -import Ouroboros.Network.PeerSelection.RootPeersDNS +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (RelayAccessPoint) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + (DNSActions) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + (newLedgerAndPublicRootDNSSemaphore) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (IsLedgerPeer (..), LedgerPeersConsensusInterface, + LedgerPeersKind (..), NumberOfPeers (..), TraceLedgerPeers, + UseLedgerAfter, withLedgerPeers) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + (TraceLocalRootPeers, localRootPeersProvider) +import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + (TracePublicRootPeers, publicRootPeersProvider) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) import Ouroboros.Network.PeerSharing (PeerSharingController (..)) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..)) +import System.Random (StdGen) withPeerSelectionActions @@ -56,8 +70,8 @@ withPeerSelectionActions ) => Tracer m (TraceLocalRootPeers peeraddr exception) -> Tracer m TracePublicRootPeers + -> Tracer m TraceLedgerPeers -> (IP -> Socket.PortNumber -> peeraddr) - -> DNSSemaphore m -> DNSActions resolver exception m -> STM m PeerSelectionTargets -> STM m [( HotValency @@ -75,8 +89,13 @@ withPeerSelectionActions -> STM m (peeraddr, PeerSharing) -- ^ Read New Inbound Connections -> PeerStateActions peeraddr peerconn m - -> (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime))) - -> ( Async m Void + -> StdGen + -- ^ Random generator for picking ledger peers + -> LedgerPeersConsensusInterface m + -- ^ Get Ledger Peers comes from here + -> STM m UseLedgerAfter + -- ^ Get Use Ledger After value + -> ( (Async m Void, Async m Void) -> PeerSelectionActions peeraddr peerconn m -> m a) -- ^ continuation, receives a handle to the local roots peer provider thread @@ -85,8 +104,8 @@ withPeerSelectionActions withPeerSelectionActions localRootTracer publicRootTracer + ledgerPeersTracer toPeerAddr - dnsSemaphore dnsActions readPeerSelectionTargets readLocalRootPeers @@ -96,35 +115,45 @@ withPeerSelectionActions readPeerSharingController readNewInboundConnections peerStateActions - getLedgerPeers + ledgerPeersRng + ledgerPeersConsensusInterface + getUseLedgerAfter k = do localRootsVar <- newTVarIO mempty - let peerSelectionActions = PeerSelectionActions { - readPeerSelectionTargets, - readLocalRootPeers = readTVar localRootsVar, - readNewInboundConnection = readNewInboundConnections, - peerSharing, - peerConnToPeerSharing, - requestPublicRootPeers, - requestBigLedgerPeers, - requestPeerShare, - peerStateActions - } - withAsync - (localRootPeersProvider - localRootTracer - toPeerAddr - DNS.defaultResolvConf - dnsActions - readLocalRootPeers - localRootsVar) - (\thread -> k thread peerSelectionActions) + + withLedgerPeers ledgerPeersRng toPeerAddr ledgerPeersTracer getUseLedgerAfter + ledgerPeersConsensusInterface dnsActions + (\getLedgerPeers lpThread -> do + let peerSelectionActions = PeerSelectionActions { + readPeerSelectionTargets, + readLocalRootPeers = readTVar localRootsVar, + readNewInboundConnection = readNewInboundConnections, + peerSharing, + peerConnToPeerSharing, + requestBigLedgerPeers = requestBigLedgerPeers getLedgerPeers, + requestPublicRootPeers = requestPublicRootPeers getLedgerPeers, + requestPeerShare, + peerStateActions + } + withAsync + (localRootPeersProvider + localRootTracer + toPeerAddr + DNS.defaultResolvConf + dnsActions + readLocalRootPeers + localRootsVar) + (\lrppThread -> k (lpThread, lrppThread) peerSelectionActions) + ) where -- We first try to get public root peers from the ledger, but if it fails -- (for example because the node hasn't synced far enough) we fall back -- to using the manually configured bootstrap root peers. - requestPublicRootPeers :: Int -> m (Map peeraddr (PeerAdvertise, IsLedgerPeer), DiffTime) - requestPublicRootPeers n = do + requestPublicRootPeers + :: (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime))) + -> Int + -> m (Map peeraddr (PeerAdvertise, IsLedgerPeer), DiffTime) + requestPublicRootPeers getLedgerPeers n = do peers_m <- getLedgerPeers (NumberOfPeers $ fromIntegral n) AllLedgerPeers case peers_m of -- No peers from Ledger @@ -147,7 +176,8 @@ withPeerSelectionActions -- `/etc/resolv.conf`: -- https://github.com/input-output-hk/cardano-node/issues/731 requestConfiguredRootPeers :: Int -> m (Map peeraddr PeerAdvertise, DiffTime) - requestConfiguredRootPeers n = + requestConfiguredRootPeers n = do + dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore publicRootPeersProvider publicRootTracer toPeerAddr dnsSemaphore @@ -156,8 +186,11 @@ withPeerSelectionActions dnsActions ($ n) - requestBigLedgerPeers :: Int -> m (Set peeraddr, DiffTime) - requestBigLedgerPeers n = do + requestBigLedgerPeers + :: (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime))) + -> Int + -> m (Set peeraddr, DiffTime) + requestBigLedgerPeers getLedgerPeers n = do peers_m <- getLedgerPeers (NumberOfPeers $ fromIntegral n) BigLedgerPeers case peers_m of Nothing -> do diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs index 8f50200e4ae..b3736bf01bf 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs @@ -9,7 +9,7 @@ module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions DNSActions (..) -- * DNSActions IO , ioDNSActions - , LookupReqs (..) + , DNSLookupType (..) -- * Utils -- ** Resource , Resource (..) @@ -43,10 +43,10 @@ import Network.DNS (DNSError) import qualified Network.DNS as DNS -data LookupReqs = LookupReqAOnly - | LookupReqAAAAOnly - | LookupReqAAndAAAA - deriving Show +data DNSLookupType = LookupReqAOnly + | LookupReqAAAAOnly + | LookupReqAAndAAAA + deriving Show data DNSorIOError exception = DNSError !DNSError @@ -178,7 +178,7 @@ getResolver resolvConf = do -- -- It guarantees that returned TTLs are strictly greater than 0. -- -ioDNSActions :: LookupReqs +ioDNSActions :: DNSLookupType -> DNSActions DNS.Resolver IOException IO ioDNSActions = \reqs -> DNSActions { @@ -349,7 +349,7 @@ ioDNSActions = ] - lookupWithTTL :: LookupReqs + lookupWithTTL :: DNSLookupType -> DNS.ResolvConf -> DNS.Resolver -> DNS.Domain diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSSemaphore.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSSemaphore.hs new file mode 100644 index 00000000000..0601f1ffd14 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSSemaphore.hs @@ -0,0 +1,45 @@ + +module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + ( -- * DNS semaphore + DNSSemaphore + , newLedgerAndPublicRootDNSSemaphore + , newDNSLocalRootSemaphore + , withDNSSemaphore + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Concurrent.Class.MonadSTM.TSem +import Control.Monad.Class.MonadThrow + +-- | Maximal concurrency when resolving DNS names of root and ledger peers. +-- +maxDNSConcurrency :: Integer +maxDNSConcurrency = 8 + +-- | Maximal concurrency when resolving DNS names of local root peers. +-- +maxDNSLocalRootConcurrency :: Integer +maxDNSLocalRootConcurrency = 2 + +-- | A semaphore used to limit concurrency of dns names resolution. +-- +newtype DNSSemaphore m = DNSSemaphore (TSem m) + +-- | Create a `DNSSemaphore` for root and ledger peers. +-- +newLedgerAndPublicRootDNSSemaphore :: MonadSTM m => m (DNSSemaphore m) +newLedgerAndPublicRootDNSSemaphore = DNSSemaphore <$> atomically (newTSem maxDNSConcurrency) + +-- | Create a `DNSSemaphore` for local root peers. +-- +newDNSLocalRootSemaphore :: MonadSTM m => STM m (DNSSemaphore m) +newDNSLocalRootSemaphore = DNSSemaphore <$> newTSem maxDNSLocalRootConcurrency + +-- | Run a computation by attempting to acquire the semaphore first. +-- On termination or failure free the semaphore +-- +withDNSSemaphore :: (MonadSTM m, MonadThrow m) => DNSSemaphore m -> m a -> m a +withDNSSemaphore (DNSSemaphore s) = + bracket_ (atomically $ waitTSem s) + (atomically $ signalTSem s) + diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LedgerPeers.hs similarity index 70% rename from ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs rename to ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LedgerPeers.hs index b80f84e9400..b6a367d56b8 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LedgerPeers.hs @@ -1,35 +1,30 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Ouroboros.Network.PeerSelection.LedgerPeers - ( DomainAccessPoint (..) - , IP.IP (..) - , LedgerPeersConsensusInterface (..) - , RelayAccessPoint (..) - , PoolStake (..) - , AccPoolStake (..) - , TraceLedgerPeers (..) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + ( -- * Ledger Peers specific data types + UseLedgerAfter (..) + , IsLedgerPeer (..) , NumberOfPeers (..) + , LedgerPeersConsensusInterface (..) , LedgerPeersKind (..) + -- * Ledger Peers specific functions , accPoolStake , accBigPoolStake - , withLedgerPeers - , UseLedgerAfter (..) - , IsLedgerPeer (..) - , IsBigLedgerPeer (..) - , Socket.PortNumber - -- Re-exports for testing purposes , bigLedgerPeerQuota + -- * DNS based provider for ledger root peers + , withLedgerPeers + -- * Internal only exported for testing purposes + , resolveLedgerPeers + , TraceLedgerPeers (..) ) where - -import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad (when) import Control.Monad.Class.MonadAsync @@ -44,20 +39,33 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Ord (Down (..)) import Data.Ratio -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Void (Void) -import Data.Word -import qualified Network.Socket as Socket import System.Random import Cardano.Slotting.Slot (SlotNo) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (AccPoolStake (..), IsBigLedgerPeer (..), PoolStake (..)) -import Ouroboros.Network.PeerSelection.RootPeersDNS - (DomainAccessPoint (..), RelayAccessPoint (..)) + (AccPoolStake (..), PoolStake (..)) import Text.Printf +import Data.Foldable (foldlM) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Void (Void) +import Data.Word (Word16, Word64) + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadThrow + + +import qualified Network.DNS as DNS +import qualified Network.Socket as Socket + +import Ouroboros.Network.PeerSelection.RelayAccessPoint +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + (DNSActions (..), DNSorIOError (..), Resource (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + (DNSSemaphore, newLedgerAndPublicRootDNSSemaphore, + withDNSSemaphore) + -- | Only use the ledger after the given slot number. data UseLedgerAfter = DontUseLedger | UseLedgerAfter SlotNo deriving (Eq, Show) @@ -97,6 +105,9 @@ data TraceLedgerPeers = -- ^ Trace for fetching a new list of peers from the ledger. The first Int -- is the number of ledger peers returned the latter is the number of big -- ledger peers. + | TraceLedgerPeersDomains [DomainAccessPoint] + | TraceLedgerPeersResult DNS.Domain [(IP, DNS.TTL)] + | TraceLedgerPeersFailure DNS.Domain DNS.DNSError | DisabledLedgerPeers -- ^ Trace for when getting peers from the ledger is disabled, that is DontUseLedger. | TraceUseLedgerAfter UseLedgerAfter @@ -147,6 +158,12 @@ instance Show TraceLedgerPeers where show (NotEnoughLedgerPeers (NumberOfPeers n) numOfLedgerPeers) = printf "Not enough ledger peers to pick %d out of %d" n numOfLedgerPeers + show (TraceLedgerPeersDomains domains) = "Resolving " ++ show domains + show (TraceLedgerPeersResult domain l) = + "Resolution success " ++ show domain ++ " " ++ show l + show (TraceLedgerPeersFailure domain err) = + "Resolution failed " ++ show domain ++ " " ++ show err + -- | Convert a list of pools with stake to a Map keyed on the accumulated stake. -- Consensus provides a list of pairs of relative stake and corresponding relays for all usable @@ -308,9 +325,11 @@ long_PEER_LIST_LIFE_TIME = 1847 -- a prime number! -- | Run the LedgerPeers worker thread. -- -ledgerPeersThread :: forall m peerAddr. +ledgerPeersThread :: forall m peerAddr resolver exception. ( MonadAsync m , MonadMonotonicTime m + , MonadThrow m + , Exception exception , Ord peerAddr ) => StdGen @@ -318,27 +337,32 @@ ledgerPeersThread :: forall m peerAddr. -> Tracer m TraceLedgerPeers -> STM m UseLedgerAfter -> LedgerPeersConsensusInterface m - -> ([DomainAccessPoint] -> m (Map DomainAccessPoint (Set peerAddr))) + -> DNSActions resolver exception m -> STM m (NumberOfPeers, LedgerPeersKind) -- ^ a blocking action which receives next request for more -- ledger peers -> (Maybe (Set peerAddr, DiffTime) -> STM m ()) -> m Void -ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter LedgerPeersConsensusInterface{..} doResolve - getReq putRsp = - go inRng (Time 0) Map.empty Map.empty +ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter + LedgerPeersConsensusInterface{..} dnsActions + getReq putRsp = do + dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore + go inRng (Time 0) Map.empty Map.empty dnsSemaphore where - go :: StdGen -> Time + go :: StdGen + -> Time -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) + -> DNSSemaphore m -> m Void - go rng oldTs peerMap bigPeerMap = do + go rng oldTs peerMap bigPeerMap dnsSemaphore = do useLedgerAfter <- atomically readUseLedgerAfter traceWith tracer (TraceUseLedgerAfter useLedgerAfter) - let peerListLifeTime = if Map.null peerMap && isLedgerPeersEnabled useLedgerAfter - then short_PEER_LIST_LIFE_TIME - else long_PEER_LIST_LIFE_TIME + let peerListLifeTime = + if Map.null peerMap && isLedgerPeersEnabled useLedgerAfter + then short_PEER_LIST_LIFE_TIME + else long_PEER_LIST_LIFE_TIME traceWith tracer WaitingOnRequest -- wait until next request of ledger peers @@ -362,13 +386,12 @@ ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter LedgerPeersConsensu else do traceWith tracer $ ReusingLedgerState (Map.size peerMap) age return (peerMap, bigPeerMap, oldTs) - if Map.null peerMap' then do when (isLedgerPeersEnabled useLedgerAfter) $ traceWith tracer FallingBackToPublicRootPeers atomically $ putRsp Nothing - go rng ts peerMap' bigPeerMap' + go rng ts peerMap' bigPeerMap' dnsSemaphore else do let ttl = 5 -- TTL, used as re-request interval by the governor. @@ -388,16 +411,24 @@ ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter LedgerPeersConsensu traceWith tracer (PickedLedgerPeers numRequested pickedPeers) - let (plainAddrs, domains) = foldl' partitionPeer (Set.empty, []) pickedPeers + let (plainAddrs, domains) = + foldl' partitionPeer (Set.empty, []) pickedPeers - domainAddrs <- doResolve domains + domainAddrs <- resolveLedgerPeers tracer + toPeerAddr + dnsSemaphore + DNS.defaultResolvConf + dnsActions + domains let (rng'', rngDomain) = split rng' - pickedAddrs = snd $ foldl' pickDomainAddrs (rngDomain, plainAddrs) - domainAddrs + pickedAddrs = + snd $ foldl' pickDomainAddrs + (rngDomain, plainAddrs) + domainAddrs atomically $ putRsp $ Just (pickedAddrs, ttl) - go rng'' ts peerMap' bigPeerMap' + go rng'' ts peerMap' bigPeerMap' dnsSemaphore -- Randomly pick one of the addresses returned in the DNS result. pickDomainAddrs :: (StdGen, Set peerAddr) @@ -410,22 +441,24 @@ ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter LedgerPeersConsensu (rng', Set.insert pickedAddr pickedAddrs) - -- Divide the picked peers form the ledger into addresses we can use directly and - -- domain names that we need to resolve. + -- Divide the picked peers form the ledger into addresses we can use + -- directly and domain names that we need to resolve. partitionPeer :: (Set peerAddr, [DomainAccessPoint]) -> RelayAccessPoint -> (Set peerAddr, [DomainAccessPoint]) - partitionPeer (addrs, domains) (RelayDomainAccessPoint domain) = (addrs, domain : domains) + partitionPeer (addrs, domains) (RelayDomainAccessPoint domain) = + (addrs, domain : domains) partitionPeer (addrs, domains) (RelayAccessAddress ip port) = - let !addr = toPeerAddr ip port in - (Set.insert addr addrs, domains) - + let !addr = toPeerAddr ip port + in (Set.insert addr addrs, domains) -- | For a LedgerPeers worker thread and submit request and receive responses. -- -withLedgerPeers :: forall peerAddr m a. +withLedgerPeers :: forall peerAddr resolver exception m a. ( MonadAsync m + , MonadThrow m , MonadMonotonicTime m + , Exception exception , Ord peerAddr ) => StdGen @@ -433,23 +466,110 @@ withLedgerPeers :: forall peerAddr m a. -> Tracer m TraceLedgerPeers -> STM m UseLedgerAfter -> LedgerPeersConsensusInterface m - -> ([DomainAccessPoint] -> m (Map DomainAccessPoint (Set peerAddr))) - -> ( (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime))) + -> DNSActions resolver exception m + -> ( (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime))) -> Async m Void -> m a ) -> m a -withLedgerPeers inRng toPeerAddr tracer readUseLedgerAfter interface doResolve k = do +withLedgerPeers inRng toPeerAddr tracer readUseLedgerAfter interface dnsActions k = do reqVar <- newEmptyTMVarIO respVar <- newEmptyTMVarIO let getRequest = takeTMVar reqVar putResponse = putTMVar respVar request :: NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime)) - request = \numberOfPeers ledgerDistribution -> do - atomically $ putTMVar reqVar (numberOfPeers, ledgerDistribution) + request = \numberOfPeers ledgerPeersKind -> do + atomically $ putTMVar reqVar (numberOfPeers, ledgerPeersKind) atomically $ takeTMVar respVar withAsync ( ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter - interface doResolve - getRequest putResponse ) + interface dnsActions getRequest putResponse ) $ \ thread -> k request thread +-- | Provides DNS resolution functionality. +-- +-- Concurrently resolve DNS names, respecting the 'maxDNSConcurrency' limit. +-- +resolveLedgerPeers + :: forall m peerAddr resolver exception. + ( Ord peerAddr + , MonadThrow m + , MonadAsync m + , Exception exception + ) + => Tracer m TraceLedgerPeers + -> (IP.IP -> Socket.PortNumber -> peerAddr) + -> DNSSemaphore m + -> DNS.ResolvConf + -> DNSActions resolver exception m + -> [DomainAccessPoint] + -> m (Map DomainAccessPoint (Set peerAddr)) +resolveLedgerPeers tracer + toPeerAddr + dnsSemaphore + resolvConf + DNSActions { + dnsResolverResource, + dnsLookupWithTTL + } + domains + = do + traceWith tracer (TraceLedgerPeersDomains domains) + rr <- dnsResolverResource resolvConf + resourceVar <- newTVarIO rr + resolveDomains resourceVar + where + resolveDomains + :: StrictTVar m (Resource m (DNSorIOError exception) resolver) + -> m (Map DomainAccessPoint (Set peerAddr)) + resolveDomains resourceVar = do + rr <- atomically $ readTVar resourceVar + (er, rr') <- withResource rr + atomically $ writeTVar resourceVar rr' + case er of + Left (DNSError err) -> throwIO err + Left (IOError err) -> throwIO err + Right resolver -> do + let lookups = + [ (,) domain + <$> withDNSSemaphore dnsSemaphore + (dnsLookupWithTTL + resolvConf + resolver + (dapDomain domain)) + | domain <- domains ] + -- The timeouts here are handled by the 'lookupWithTTL'. They're + -- configured via the DNS.ResolvConf resolvTimeout field and + -- defaults to 3 sec. + results <- withAsyncAll lookups (atomically . mapM waitSTM) + foldlM processResult Map.empty results + + processResult :: Map DomainAccessPoint (Set peerAddr) + -> (DomainAccessPoint, ([DNS.DNSError], [(IP, DNS.TTL)])) + -> m (Map DomainAccessPoint (Set peerAddr)) + processResult mr (domain, (errs, ipsttls)) = do + mapM_ (traceWith tracer . TraceLedgerPeersFailure (dapDomain domain)) + errs + when (not $ null ipsttls) $ + traceWith tracer $ TraceLedgerPeersResult (dapDomain domain) ipsttls + + return $ Map.alter addFn domain mr + where + addFn :: Maybe (Set peerAddr) -> Maybe (Set peerAddr) + addFn Nothing = + let ips = map fst ipsttls + !addrs = map (\ip -> toPeerAddr ip (dapPortNumber domain)) + ips + !addrSet = Set.fromList addrs in + Just addrSet + addFn (Just addrSet) = + let ips = map fst ipsttls + !addrs = map (\ip -> toPeerAddr ip (dapPortNumber domain)) + ips + !addrSet' = Set.union addrSet (Set.fromList addrs) in + Just addrSet' + +withAsyncAll :: MonadAsync m => [m a] -> ([Async m a] -> m b) -> m b +withAsyncAll xs0 action = go [] xs0 + where + go as [] = action (reverse as) + go as (x:xs) = withAsync x (\a -> go (a:as) xs) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs similarity index 52% rename from ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs rename to ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs index 5b39ad7a0e6..a615dfeb901 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs @@ -1,54 +1,25 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -module Ouroboros.Network.PeerSelection.RootPeersDNS - ( -- * DNS based actions for local and public root providers - DNSActions (..) - -- * DNS resolver IO auxiliary functions - , constantResource - -- ** DNSActions IO - , ioDNSActions - , LookupReqs (..) - -- * DNS semaphore - , DNSSemaphore - , newLocalAndPublicRootDNSSemaphore - -- * DNS based provider for local root peers - , localRootPeersProvider - , DomainAccessPoint (..) - , RelayAccessPoint (..) - , IP.IP (..) +module Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + ( -- * DNS based provider for local root peers + localRootPeersProvider , TraceLocalRootPeers (..) - -- * DNS based provider for public root peers - , publicRootPeersProvider - , TracePublicRootPeers (..) - -- DNS lookup support - , resolveDomainAccessPoint - -- * DNS type re-exports - , DNS.ResolvConf - , DNS.Domain - , DNS.TTL - -- * Socket type re-exports - , Socket.PortNumber ) where -import Data.Foldable (foldlM) import Data.List (elemIndex) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as Set import Data.Void (Void, absurd) import Data.Word (Word32) import Control.Applicative (Alternative, (<|>)) import Control.Concurrent.Class.MonadSTM.Strict -import Control.Concurrent.Class.MonadSTM.TSem import Control.Monad (when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow @@ -56,8 +27,6 @@ import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer (..), contramap, traceWith) - -import qualified Data.IP as IP import qualified Network.DNS as DNS import qualified Network.Socket as Socket @@ -65,16 +34,13 @@ import Data.Bifunctor (second) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) import Ouroboros.Network.PeerSelection.RelayAccessPoint import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions - (DNSActions (..), DNSorIOError (..), LookupReqs (..), - Resource (..), constantResource, ioDNSActions, + (DNSActions (..), DNSorIOError (..), Resource (..), withResource') +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + (DNSSemaphore, newDNSLocalRootSemaphore, withDNSSemaphore) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) ------------------------------------------------ --- local root peer set provider based on DNS --- - data TraceLocalRootPeers peerAddr exception = TraceLocalRootDomains [( HotValency , WarmValency @@ -99,36 +65,6 @@ data TraceLocalRootPeers peerAddr exception = | TraceLocalRootError DomainAccessPoint SomeException deriving Show - --- | Maximal concurrency when resolving DNS names of root and ledger peers. --- -maxDNSConcurrency :: Integer -maxDNSConcurrency = 8 - --- | Maximal concurrency when resolving DNS names of local root peers. --- -maxDNSLocalRootConcurrency :: Integer -maxDNSLocalRootConcurrency = 2 - --- | A semaphore used to limit concurrency of dns names resolution. --- -newtype DNSSemaphore m = DNSSemaphore (TSem m) - --- | Create a `DNSSemaphore` for root and ledger peers. --- -newLocalAndPublicRootDNSSemaphore :: MonadSTM m => m (DNSSemaphore m) -newLocalAndPublicRootDNSSemaphore = DNSSemaphore <$> atomically (newTSem maxDNSConcurrency) - --- | Create a `DNSSemaphore` for local root peers. --- -newDNSLocalRootSemaphore :: MonadSTM m => STM m (DNSSemaphore m) -newDNSLocalRootSemaphore = DNSSemaphore <$> newTSem maxDNSLocalRootConcurrency - -withDNSSemaphore :: (MonadSTM m, MonadThrow m) => DNSSemaphore m -> m a -> m a -withDNSSemaphore (DNSSemaphore s) = - bracket_ (atomically $ waitTSem s) - (atomically $ signalTSem s) - -- | Resolve 'RelayAddress'-es of local root peers using dns if needed. Local -- roots are provided wrapped in a 'StrictTVar', which value might change -- (re-read form a config file). The resolved dns names are available through @@ -174,7 +110,9 @@ localRootPeersProvider tracer -- | Loop function that monitors DNS Domain resolution threads and restarts -- if either these threads fail or detects the local configuration changed. -- - loop :: DNSSemaphore m -> [(HotValency, WarmValency, Map RelayAccessPoint PeerAdvertise)] -> m Void + loop :: DNSSemaphore m + -> [(HotValency, WarmValency, Map RelayAccessPoint PeerAdvertise)] + -> m Void loop dnsSemaphore domainsGroups = do traceWith tracer (TraceLocalRootDomains domainsGroups) rr <- dnsAsyncResolverResource resolvConf @@ -210,21 +148,21 @@ localRootPeersProvider tracer domainsGroups' <- withAsyncAll (monitorDomain rr dnsSemaphore dnsDomainMapVar `map` domains) $ \as -> do res <- atomically $ - -- wait until any of the monitoring threads errors - ((\(a, res) -> - let domain :: DomainAccessPoint - domain = case a `elemIndex` as of - Nothing -> error "localRootPeersProvider: impossible happened" - Just idx -> case domains !! idx of x -> x - in either (Left . (domain,)) absurd res) - -- the monitoring thread cannot return, it can only error - <$> waitAnyCatchSTM as) - <|> - -- wait for configuration changes - (do a <- readLocalRootPeers - -- wait until the input domains groups changes - check (a /= domainsGroups) - return (Right a)) + -- wait until any of the monitoring threads errors + ((\(a, res) -> + let domain :: DomainAccessPoint + domain = case a `elemIndex` as of + Nothing -> error "localRootPeersProvider: impossible happened" + Just idx -> case domains !! idx of x -> x + in either (Left . (domain,)) absurd res) + -- the monitoring thread cannot return, it can only error + <$> waitAnyCatchSTM as) + <|> + -- wait for configuration changes + (do a <- readLocalRootPeers + -- wait until the input domains groups changes + check (a /= domainsGroups) + return (Right a)) case res of Left (domain, err) -> traceWith tracer (TraceLocalRootError domain err) -- current domain groups haven't changed, we @@ -239,12 +177,17 @@ localRootPeersProvider tracer loop dnsSemaphore domainsGroups' resolveDomain - :: resolver + :: DNSSemaphore m + -> resolver -> DomainAccessPoint -> m (Either [DNS.DNSError] [(peerAddr, DNS.TTL)]) - resolveDomain resolver + resolveDomain dnsSemaphore resolver domain@DomainAccessPoint {dapDomain, dapPortNumber} = do - (errs, results) <- dnsLookupWithTTL resolvConf resolver dapDomain + (errs, results) <- withDNSSemaphore dnsSemaphore + (dnsLookupWithTTL + resolvConf + resolver + dapDomain) mapM_ (traceWith tracer . TraceLocalRootFailure domain . DNSError) errs @@ -285,7 +228,7 @@ localRootPeersProvider tracer rr --- Resolve 'domain' - reply <- withDNSSemaphore dnsSemaphore (resolveDomain resolver domain) + reply <- resolveDomain dnsSemaphore resolver domain case reply of Left errs -> go rrNext (minimum $ map (\err -> ttlForDnsError err ttl) errs) @@ -363,180 +306,13 @@ localRootPeersProvider tracer ) ) ---------------------------------------------- --- Public root peer set provider using DNS --- +-- * Aux -data TracePublicRootPeers = - TracePublicRootRelayAccessPoint (Map RelayAccessPoint PeerAdvertise) - | TracePublicRootDomains [DomainAccessPoint] - | TracePublicRootResult DNS.Domain [(IP, DNS.TTL)] - | TracePublicRootFailure DNS.Domain DNS.DNSError - --TODO: classify DNS errors, config error vs transitory - deriving Show - --- | --- -publicRootPeersProvider - :: forall peerAddr resolver exception a m. - (MonadThrow m, MonadAsync m, Exception exception, - Ord peerAddr) - => Tracer m TracePublicRootPeers - -> (IP -> Socket.PortNumber -> peerAddr) - -> DNSSemaphore m - -> DNS.ResolvConf - -> STM m (Map RelayAccessPoint PeerAdvertise) - -> DNSActions resolver exception m - -> ((Int -> m (Map peerAddr PeerAdvertise, DiffTime)) -> m a) - -> m a -publicRootPeersProvider tracer - toPeerAddr - dnsSemaphore - resolvConf - readDomains - DNSActions { - dnsResolverResource, - dnsLookupWithTTL - } - action = do - domains <- atomically readDomains - traceWith tracer (TracePublicRootRelayAccessPoint domains) - rr <- dnsResolverResource resolvConf - resourceVar <- newTVarIO rr - action (requestPublicRootPeers resourceVar) - where - processResult :: ((DomainAccessPoint, PeerAdvertise), ([DNS.DNSError], [(IP, DNS.TTL)])) - -> m ((DomainAccessPoint, PeerAdvertise), [(IP, DNS.TTL)]) - processResult ((domain, pa), (errs, result)) = do - mapM_ (traceWith tracer . TracePublicRootFailure (dapDomain domain)) - errs - when (not $ null result) $ - traceWith tracer $ TracePublicRootResult (dapDomain domain) result - - return ((domain, pa), result) - - requestPublicRootPeers - :: StrictTVar m (Resource m (DNSorIOError exception) resolver) - -> Int - -> m (Map peerAddr PeerAdvertise, DiffTime) - requestPublicRootPeers resourceVar _numRequested = do - domains <- atomically readDomains - traceWith tracer (TracePublicRootRelayAccessPoint domains) - rr <- atomically $ readTVar resourceVar - (er, rr') <- withResource rr - atomically $ writeTVar resourceVar rr' - case er of - Left (DNSError err) -> throwIO err - Left (IOError err) -> throwIO err - Right resolver -> do - let lookups = - [ ((DomainAccessPoint domain port, pa),) - <$> withDNSSemaphore dnsSemaphore - (dnsLookupWithTTL - resolvConf - resolver - domain) - | (RelayAccessDomain domain port, pa) <- Map.assocs domains ] - -- The timeouts here are handled by the 'lookupWithTTL'. They're - -- configured via the DNS.ResolvConf resolvTimeout field and defaults - -- to 3 sec. - results <- withAsyncAll lookups (atomically . mapM waitSTM) - results' <- mapM processResult results - let successes = [ ( (toPeerAddr ip dapPortNumber, pa) - , ipttl) - | ( (DomainAccessPoint {dapPortNumber}, pa) - , ipttls) <- results' - , (ip, ipttl) <- ipttls - ] - !domainsIps = [(toPeerAddr ip port, pa) - | (RelayAccessAddress ip port, pa) <- Map.assocs domains ] - !ips = Map.fromList (map fst successes) `Map.union` Map.fromList domainsIps - !ttl = ttlForResults (map snd successes) - -- If all the lookups failed we'll return an empty set with a minimum - -- TTL, and the governor will invoke its exponential backoff. - return (ips, ttl) - --- | Provides DNS resolution functionality. --- --- Concurrently resolve DNS names, respecting the 'maxDNSConcurrency' limit. --- -resolveDomainAccessPoint - :: forall exception resolver m. - (MonadThrow m, MonadAsync m, Exception exception) - => Tracer m TracePublicRootPeers - -> DNSSemaphore m - -> DNS.ResolvConf - -> DNSActions resolver exception m - -> [DomainAccessPoint] - -> m (Map DomainAccessPoint (Set Socket.SockAddr)) -resolveDomainAccessPoint tracer - dnsSemaphore - resolvConf - DNSActions { - dnsResolverResource, - dnsLookupWithTTL - } - domains - = do - traceWith tracer (TracePublicRootDomains domains) - rr <- dnsResolverResource resolvConf - resourceVar <- newTVarIO rr - resolveDomains resourceVar +withAsyncAll :: MonadAsync m => [m a] -> ([Async m a] -> m b) -> m b +withAsyncAll xs0 action = go [] xs0 where - resolveDomains - :: StrictTVar m (Resource m (DNSorIOError exception) resolver) - -> m (Map DomainAccessPoint (Set Socket.SockAddr)) - resolveDomains resourceVar = do - rr <- atomically $ readTVar resourceVar - (er, rr') <- withResource rr - atomically $ writeTVar resourceVar rr' - case er of - Left (DNSError err) -> throwIO err - Left (IOError err) -> throwIO err - Right resolver -> do - let lookups = - [ (,) domain - <$> withDNSSemaphore dnsSemaphore - (dnsLookupWithTTL - resolvConf - resolver - (dapDomain domain)) - | domain <- domains ] - -- The timeouts here are handled by the 'lookupWithTTL'. They're - -- configured via the DNS.ResolvConf resolvTimeout field and defaults - -- to 3 sec. - results <- withAsyncAll lookups (atomically . mapM waitSTM) - foldlM processResult Map.empty results - - processResult :: Map DomainAccessPoint (Set Socket.SockAddr) - -> (DomainAccessPoint, ([DNS.DNSError], [(IP, DNS.TTL)])) - -> m (Map DomainAccessPoint (Set Socket.SockAddr)) - processResult mr (domain, (errs, ipsttls)) = do - mapM_ (traceWith tracer . TracePublicRootFailure (dapDomain domain)) - errs - when (not $ null ipsttls) $ - traceWith tracer $ TracePublicRootResult (dapDomain domain) ipsttls - - return $ Map.alter addFn domain mr - where - addFn :: Maybe (Set Socket.SockAddr) -> Maybe (Set Socket.SockAddr) - addFn Nothing = - let ips = map fst ipsttls - !addrs = map (\ip -> IP.toSockAddr (ip, dapPortNumber domain)) - ips - !addrSet = Set.fromList addrs in - Just addrSet - addFn (Just addrSet) = - let ips = map fst ipsttls - !addrs = map (\ip -> IP.toSockAddr (ip, dapPortNumber domain)) - ips - !addrSet' = Set.union addrSet (Set.fromList addrs) in - Just addrSet' - - ---------------------------------------------- --- Shared utils --- + go as [] = action (reverse as) + go as (x:xs) = withAsync x (\a -> go (a:as) xs) -- | Policy for TTL for positive results ttlForResults :: [DNS.TTL] -> DiffTime @@ -550,58 +326,14 @@ ttlForResults ttls = clipTTLBelow . (fromIntegral :: Word32 -> DiffTime) $ maximum ttls +-- | Limit insane TTL choices. +clipTTLAbove, clipTTLBelow :: DiffTime -> DiffTime +clipTTLBelow = max 60 -- between 1min +clipTTLAbove = min 86400 -- and 24hrs + -- | Policy for TTL for negative results -- Cache negative response for 3hrs -- Otherwise, use exponential backoff, up to a limit ttlForDnsError :: DNS.DNSError -> DiffTime -> DiffTime ttlForDnsError DNS.NameError _ = 10800 ttlForDnsError _ ttl = clipTTLAbove (ttl * 2 + 5) - --- | Limit insane TTL choices. -clipTTLAbove, clipTTLBelow :: DiffTime -> DiffTime -clipTTLBelow = max 60 -- between 1min -clipTTLAbove = min 86400 -- and 24hrs - -withAsyncAll :: MonadAsync m => [m a] -> ([Async m a] -> m b) -> m b -withAsyncAll xs0 action = go [] xs0 - where - go as [] = action (reverse as) - go as (x:xs) = withAsync x (\a -> go (a:as) xs) - ---------------------------------------------- --- Examples --- -{- -exampleLocal :: [DomainAccessPoint] -> IO () -exampleLocal domains = do - rootPeersVar <- newTVarIO Map.empty - withAsync (observer rootPeersVar Map.empty) $ \_ -> - provider rootPeersVar - where - provider rootPeersVar = - localRootPeersProvider - (showTracing stdoutTracer) - DNS.defaultResolvConf - rootPeersVar - (map (\d -> (d, DoAdvertisePeer)) domains) - - observer :: (Eq a, Show a) => StrictTVar IO a -> a -> IO () - observer var fingerprint = do - x <- atomically $ do - x <- readTVar var - check (x /= fingerprint) - return x - traceWith (showTracing stdoutTracer) x - observer var x - -examplePublic :: [DomainAccessPoint] -> IO () -examplePublic domains = do - publicRootPeersProvider - (showTracing stdoutTracer) - DNS.defaultResolvConf - domains $ \requestPublicRootPeers -> - forever $ do - (ips, ttl) <- requestPublicRootPeers 42 - traceWith (showTracing stdoutTracer) (ips, ttl) - threadDelay ttl --} diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/PublicRootPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/PublicRootPeers.hs new file mode 100644 index 00000000000..9eb350fbfef --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/PublicRootPeers.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + ( -- * DNS based provider for public root peers + publicRootPeersProvider + , TracePublicRootPeers (..) + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Word (Word32) + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad (when) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Tracer (Tracer (..), traceWith) + + +import qualified Network.DNS as DNS +import qualified Network.Socket as Socket + +import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) +import Ouroboros.Network.PeerSelection.RelayAccessPoint +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + (DNSActions (..), DNSorIOError (..), Resource (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + (DNSSemaphore, withDNSSemaphore) + +--------------------------------------------- +-- Public root peer set provider using DNS +-- + +data TracePublicRootPeers = + TracePublicRootRelayAccessPoint (Map RelayAccessPoint PeerAdvertise) + | TracePublicRootDomains [DomainAccessPoint] + | TracePublicRootResult DNS.Domain [(IP, DNS.TTL)] + | TracePublicRootFailure DNS.Domain DNS.DNSError + --TODO: classify DNS errors, config error vs transitory + deriving Show + +-- | +-- +publicRootPeersProvider + :: forall peerAddr resolver exception a m. + (MonadThrow m, MonadAsync m, Exception exception, + Ord peerAddr) + => Tracer m TracePublicRootPeers + -> (IP -> Socket.PortNumber -> peerAddr) + -> DNSSemaphore m + -> DNS.ResolvConf + -> STM m (Map RelayAccessPoint PeerAdvertise) + -> DNSActions resolver exception m + -> ((Int -> m (Map peerAddr PeerAdvertise, DiffTime)) -> m a) + -> m a +publicRootPeersProvider tracer + toPeerAddr + dnsSemaphore + resolvConf + readDomains + DNSActions { + dnsResolverResource, + dnsLookupWithTTL + } + action = do + domains <- atomically readDomains + traceWith tracer (TracePublicRootRelayAccessPoint domains) + rr <- dnsResolverResource resolvConf + resourceVar <- newTVarIO rr + action (requestPublicRootPeers resourceVar) + where + processResult :: ((DomainAccessPoint, PeerAdvertise), ([DNS.DNSError], [(IP, DNS.TTL)])) + -> m ((DomainAccessPoint, PeerAdvertise), [(IP, DNS.TTL)]) + processResult ((domain, pa), (errs, result)) = do + mapM_ (traceWith tracer . TracePublicRootFailure (dapDomain domain)) + errs + when (not $ null result) $ + traceWith tracer $ TracePublicRootResult (dapDomain domain) result + + return ((domain, pa), result) + + requestPublicRootPeers + :: StrictTVar m (Resource m (DNSorIOError exception) resolver) + -> Int + -> m (Map peerAddr PeerAdvertise, DiffTime) + requestPublicRootPeers resourceVar _numRequested = do + domains <- atomically readDomains + traceWith tracer (TracePublicRootRelayAccessPoint domains) + rr <- atomically $ readTVar resourceVar + (er, rr') <- withResource rr + atomically $ writeTVar resourceVar rr' + case er of + Left (DNSError err) -> throwIO err + Left (IOError err) -> throwIO err + Right resolver -> do + let lookups = + [ ((DomainAccessPoint domain port, pa),) + <$> withDNSSemaphore dnsSemaphore + (dnsLookupWithTTL + resolvConf + resolver + domain) + | (RelayAccessDomain domain port, pa) <- Map.assocs domains ] + -- The timeouts here are handled by the 'lookupWithTTL'. They're + -- configured via the DNS.ResolvConf resolvTimeout field and defaults + -- to 3 sec. + results <- withAsyncAll lookups (atomically . mapM waitSTM) + results' <- mapM processResult results + let successes = [ ( (toPeerAddr ip dapPortNumber, pa) + , ipttl) + | ( (DomainAccessPoint {dapPortNumber}, pa) + , ipttls) <- results' + , (ip, ipttl) <- ipttls + ] + !domainsIps = [(toPeerAddr ip port, pa) + | (RelayAccessAddress ip port, pa) <- Map.assocs domains ] + !ips = Map.fromList (map fst successes) `Map.union` Map.fromList domainsIps + !ttl = ttlForResults (map snd successes) + -- If all the lookups failed we'll return an empty set with a minimum + -- TTL, and the governor will invoke its exponential backoff. + return (ips, ttl) + +-- Aux + +withAsyncAll :: MonadAsync m => [m a] -> ([Async m a] -> m b) -> m b +withAsyncAll xs0 action = go [] xs0 + where + go as [] = action (reverse as) + go as (x:xs) = withAsync x (\a -> go (a:as) xs) + +-- | Policy for TTL for positive results +ttlForResults :: [DNS.TTL] -> DiffTime + +-- This case says we have a successful reply but there is no answer. +-- This covers for example non-existent TLDs since there is no authority +-- to say that they should not exist. +ttlForResults [] = ttlForDnsError DNS.NameError 0 +ttlForResults ttls = clipTTLBelow + . clipTTLAbove + . (fromIntegral :: Word32 -> DiffTime) + $ maximum ttls + +-- | Limit insane TTL choices. +clipTTLAbove, clipTTLBelow :: DiffTime -> DiffTime +clipTTLBelow = max 60 -- between 1min +clipTTLAbove = min 86400 -- and 24hrs + +-- | Policy for TTL for negative results +-- Cache negative response for 3hrs +-- Otherwise, use exponential backoff, up to a limit +ttlForDnsError :: DNS.DNSError -> DiffTime -> DiffTime +ttlForDnsError DNS.NameError _ = 10800 +ttlForDnsError _ ttl = clipTTLAbove (ttl * 2 + 5) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs index 9c258d54622..9eaf35a45d2 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs @@ -45,11 +45,12 @@ import Control.Exception (assert) import Control.Monad.Class.MonadTime.SI import Data.Maybe (fromMaybe) -import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..), combinePeerInformation) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers + (IsLedgerPeer (..)) -------------------------------