From 7bd75276b522b32d88a0f5d41f387f4e93cfbe4b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 13 Jan 2025 10:36:03 +0100 Subject: [PATCH] wip --- .../Network/PeerSelection/LedgerPeers/Type.hs | 50 ++--- .../Network/PeerSelection/RelayAccessPoint.hs | 187 +++++++++-------- .../src/Ouroboros/Network/Diffusion/P2P.hs | 12 +- .../Network/PeerSelection/LedgerPeers.hs | 21 +- .../PeerSelection/LedgerPeers/Common.hs | 6 +- .../Network/PeerSelection/RootPeersDNS.hs | 2 + .../PeerSelection/RootPeersDNS/DNSActions.hs | 196 +++++++++++------- .../PeerSelection/RootPeersDNS/LedgerPeers.hs | 77 +++---- .../RootPeersDNS/LocalRootPeers.hs | 115 ++++------ .../RootPeersDNS/PublicRootPeers.hs | 83 ++++---- 10 files changed, 380 insertions(+), 369 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs index a3f67ee06e5..8889457649a 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -35,7 +35,7 @@ import GHC.Generics (Generic) import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Binary qualified as Codec import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) -import Control.Applicative ((<|>)) +-- import Control.Applicative ((<|>)) import Control.Concurrent.Class.MonadSTM import Control.DeepSeq (NFData (..)) import Control.Monad (forM) @@ -43,7 +43,7 @@ import Data.Aeson import Data.Aeson.Types import Data.ByteString.Char8 qualified as BS import Data.List.NonEmpty (NonEmpty) -import Data.Text.Encoding (decodeUtf8) +-- import Data.Text.Encoding (decodeUtf8) import NoThunks.Class import Ouroboros.Network.PeerSelection.RelayAccessPoint @@ -254,32 +254,32 @@ data LedgerPeersConsensusInterface m = LedgerPeersConsensusInterface { } instance ToJSON RelayAccessPointCoded where - toJSON (RelayAccessPointCoded (RelayAccessDomain domain port)) = - object - [ "address" .= decodeUtf8 domain - , "port" .= (fromIntegral port :: Int)] - toJSON (RelayAccessPointCoded (RelayAccessSRVDomain domain)) = - object - [ "address" .= decodeUtf8 domain ] - toJSON (RelayAccessPointCoded (RelayAccessAddress ip port)) = - object - [ "address" .= show ip - , "port" .= (fromIntegral port :: Int)] + toJSON (RelayAccessPointCoded x) = toJSON x + -- toJSON (RelayAccessPointCoded (RelayAccessDomain domain port)) = + -- object + -- [ "address" .= decodeUtf8 domain + -- , "port" .= (fromIntegral port :: Int)] + -- toJSON (RelayAccessPointCoded (RelayAccessSRVDomain domain)) = + -- object + -- [ "address" .= decodeUtf8 domain ] + -- toJSON (RelayAccessPointCoded (RelayAccessAddress ip port)) = + -- object + -- [ "address" .= show ip + -- , "port" .= (fromIntegral port :: Int)] instance FromJSON RelayAccessPointCoded where parseJSON = withObject "RelayAccessPointCoded" $ \o -> do - case parseMaybe parseJSON (Object o) of - Just it@(RelayAccessAddress {}) -> return $ RelayAccessPointCoded it - _otherwise -> do - let dap = parseMaybe (fmap Left <$> parseJSON) (Object o) - <|> parseMaybe (fmap Right <$> parseJSON) (Object o) - case dap of - Just (Left (DomainPlain domain port)) -> - return $ RelayAccessPointCoded $ RelayAccessDomain (fullyQualified domain) port - Just (Right (DomainSRV domain)) -> - return $ RelayAccessPointCoded $ RelayAccessSRVDomain (fullyQualified domain) - _otherwise -> fail $ "RelayAccessPointCoded: unrecognized JSON object: " - <> show o + let f = + case parseMaybe parseJSON (Object o) of + Just it@(RelayAccessAddress {}) -> it + Just (RelayAccessDomain d p) -> + RelayAccessDomain (fullyQualified d) p + Just (RelayAccessSRVDomain d) -> + RelayAccessSRVDomain (fullyQualified d) + Nothing -> + error $ "RelayAccessPointCoded: unrecognized JSON object: " + <> show o + return $ RelayAccessPointCoded f where fullyQualified = \case domain | Just (_, '.') <- BS.unsnoc domain -> domain diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs index 66159bdf531..3b7289ac5fe 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs @@ -1,23 +1,24 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE NamedFieldPuns #-} +-- {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +-- {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +-- {-# LANGUAGE ViewPatterns #-} module Ouroboros.Network.PeerSelection.RelayAccessPoint - ( DomainAccessPoint (..) - , DomainPlainAccessPoint (..) - , DomainSRVAccessPoint (..) - , RelayAccessPoint (.., RelayDomainAccessPoint) + ( + -- DomainAccessPoint (..) + -- , DomainPlainAccessPoint (..) + -- , DomainSRVAccessPoint (..) + RelayAccessPoint (..) --, RelayDomainAccessPoint) , RelayAccessPointCoded (..) , IP.IP (..) -- * Socket type re-exports , Socket.PortNumber ) where -import Control.Applicative ((<|>)) +-- import Control.Applicative ((<|>)) import Control.DeepSeq (NFData (..)) import Control.Monad (unless) @@ -44,73 +45,73 @@ import Network.Socket qualified as Socket -- and port are obtained from the winner. -- (cf. https://www.ietf.org/rfc/rfc2782.txt) -- -data DomainAccessPoint = DomainAccessPoint !DomainPlainAccessPoint - -- ^ An @A@ or @AAAA@ DNS record - | DomainSRVAccessPoint !DomainSRVAccessPoint - -- ^ A @SRV@ DNS record - deriving (Eq, Show, Ord) - -instance ToJSON DomainAccessPoint where - toJSON (DomainAccessPoint dPlain) = toJSON dPlain - toJSON (DomainSRVAccessPoint dSRV) = toJSON dSRV - -instance FromJSON DomainAccessPoint where - parseJSON = withObject "DomainAccessPoint" $ \o -> do - let dap = parseMaybe (fmap Left <$> parseJSON) (Object o) - <|> parseMaybe (fmap Right <$> parseJSON) (Object o) - case dap of - Just (Left dPlain) -> - return $ DomainAccessPoint dPlain - Just (Right dSRV) -> - return $ DomainSRVAccessPoint dSRV - _otherwise -> fail $ "DomainAccessPoint: unrecognized JSON object: " - <> show o - --- | A product of a 'DNS.Domain' and 'Socket.PortNumber'. After resolving the --- domain we will use the 'Socket.PortNumber' to form 'Socket.SockAddr'. --- -data DomainPlainAccessPoint = DomainPlain { - dapDomain :: !DNS.Domain, - dapPortNumber :: !Socket.PortNumber - } - deriving (Eq, Show, Ord) - --- | An SRV domain is just a DNS.Domain --- -newtype DomainSRVAccessPoint = DomainSRV { - srvDomain :: DNS.Domain } - deriving (Show, Eq, Ord) - -instance FromJSON DomainPlainAccessPoint where - parseJSON = withObject "DomainPlainAccessPoint" $ \v -> do - DomainPlain - <$> (encodeUtf8 <$> v .: "address") - <*> ((fromIntegral :: Int -> Socket.PortNumber) <$> v .: "port") - -instance ToJSON DomainPlainAccessPoint where - toJSON da = - object - [ "address" .= decodeUtf8 (dapDomain da) - , "port" .= (fromIntegral (dapPortNumber da) :: Int) - ] - -instance FromJSON DomainSRVAccessPoint where - parseJSON = withObject "DomainSRVAccessPoint" $ \v -> do - DomainSRV - <$> (encodeUtf8 <$> v .: "address") - -instance ToJSON DomainSRVAccessPoint where - toJSON (DomainSRV domain) = - object - [ "address" .= decodeUtf8 domain - ] +-- data DomainAccessPoint = DomainAccessPoint !DomainPlainAccessPoint +-- -- ^ An @A@ or @AAAA@ DNS record +-- | DomainSRVAccessPoint !DomainSRVAccessPoint +-- -- ^ A @SRV@ DNS record +-- deriving (Eq, Show, Ord) + +-- instance ToJSON DomainAccessPoint where +-- toJSON (DomainAccessPoint dPlain) = toJSON dPlain +-- toJSON (DomainSRVAccessPoint dSRV) = toJSON dSRV + +-- instance FromJSON DomainAccessPoint where +-- parseJSON = withObject "DomainAccessPoint" $ \o -> do +-- let dap = parseMaybe (fmap Left <$> parseJSON) (Object o) +-- <|> parseMaybe (fmap Right <$> parseJSON) (Object o) +-- case dap of +-- Just (Left dPlain) -> +-- return $ DomainAccessPoint dPlain +-- Just (Right dSRV) -> +-- return $ DomainSRVAccessPoint dSRV +-- _otherwise -> fail $ "DomainAccessPoint: unrecognized JSON object: " +-- <> show o + +-- -- | A product of a 'DNS.Domain' and 'Socket.PortNumber'. After resolving the +-- -- domain we will use the 'Socket.PortNumber' to form 'Socket.SockAddr'. +-- -- +-- data DomainPlainAccessPoint = DomainPlain { +-- dapDomain :: !DNS.Domain, +-- dapPortNumber :: !Socket.PortNumber +-- } +-- deriving (Eq, Show, Ord) + +-- -- | An SRV domain is just a DNS.Domain +-- -- +-- newtype DomainSRVAccessPoint = DomainSRV { +-- srvDomain :: DNS.Domain } +-- deriving (Show, Eq, Ord) + +-- instance FromJSON DomainPlainAccessPoint where +-- parseJSON = withObject "DomainPlainAccessPoint" $ \v -> do +-- DomainPlain +-- <$> (encodeUtf8 <$> v .: "address") +-- <*> ((fromIntegral :: Int -> Socket.PortNumber) <$> v .: "port") + +-- instance ToJSON DomainPlainAccessPoint where +-- toJSON da = +-- object +-- [ "address" .= decodeUtf8 (dapDomain da) +-- , "port" .= (fromIntegral (dapPortNumber da) :: Int) +-- ] + +-- instance FromJSON DomainSRVAccessPoint where +-- parseJSON = withObject "DomainSRVAccessPoint" $ \v -> do +-- DomainSRV +-- <$> (encodeUtf8 <$> v .: "address") + +-- instance ToJSON DomainSRVAccessPoint where +-- toJSON (DomainSRV domain) = +-- object +-- [ "address" .= decodeUtf8 domain +-- ] -- | A relay can have either an IP address and a port number or -- a domain with a port number -- -data RelayAccessPoint = RelayAccessDomain !DNS.Domain !Socket.PortNumber +data RelayAccessPoint = RelayAccessDomain !DNS.Domain !Socket.PortNumber | RelayAccessSRVDomain !DNS.Domain - | RelayAccessAddress !IP.IP !Socket.PortNumber + | RelayAccessAddress !IP.IP !Socket.PortNumber deriving (Eq, Ord) newtype RelayAccessPointCoded = RelayAccessPointCoded { unRelayAccessPointCoded :: RelayAccessPoint } @@ -182,23 +183,23 @@ instance Show RelayAccessPoint where -- | 'RelayDomainAccessPoint' a bidirectional pattern which links -- 'RelayAccessDomain' and 'DomainAccessPoint'. -- -pattern RelayDomainAccessPoint :: DomainAccessPoint -> RelayAccessPoint -pattern RelayDomainAccessPoint dap <- (viewRelayAccessPoint -> Just dap) - where - RelayDomainAccessPoint (DomainAccessPoint (DomainPlain {dapDomain, dapPortNumber})) = - RelayAccessDomain dapDomain dapPortNumber - RelayDomainAccessPoint (DomainSRVAccessPoint (DomainSRV {srvDomain})) = - RelayAccessSRVDomain srvDomain +-- pattern RelayDomainAccessPoint :: DomainAccessPoint -> RelayAccessPoint +-- pattern RelayDomainAccessPoint dap <- (viewRelayAccessPoint -> Just dap) +-- where +-- RelayDomainAccessPoint (DomainAccessPoint (DomainPlain {dapDomain, dapPortNumber})) = +-- RelayAccessDomain dapDomain dapPortNumber +-- RelayDomainAccessPoint (DomainSRVAccessPoint (DomainSRV {srvDomain})) = +-- RelayAccessSRVDomain srvDomain -{-# COMPLETE RelayDomainAccessPoint, RelayAccessAddress #-} +-- {-# COMPLETE RelayDomainAccessPoint, RelayAccessAddress #-} -viewRelayAccessPoint :: RelayAccessPoint -> Maybe DomainAccessPoint -viewRelayAccessPoint (RelayAccessDomain dapDomain dapPortNumber) = - Just $ DomainAccessPoint $ DomainPlain {dapDomain, dapPortNumber} -viewRelayAccessPoint (RelayAccessSRVDomain srvDomain) = - Just $ DomainSRVAccessPoint $ DomainSRV {srvDomain} -viewRelayAccessPoint RelayAccessAddress {} = - Nothing +-- viewRelayAccessPoint :: RelayAccessPoint -> Maybe DomainAccessPoint +-- viewRelayAccessPoint (RelayAccessDomain dapDomain dapPortNumber) = +-- Just $ DomainAccessPoint $ DomainPlain {dapDomain, dapPortNumber} +-- viewRelayAccessPoint (RelayAccessSRVDomain srvDomain) = +-- Just $ DomainSRVAccessPoint $ DomainSRV {srvDomain} +-- viewRelayAccessPoint RelayAccessAddress {} = +-- Nothing -- 'IP' nor 'IPv6' is strict, 'IPv4' is strict only because it's a newtype for @@ -222,6 +223,13 @@ instance FromJSON RelayAccessPoint where Nothing -> return $ RelayAccessSRVDomain addr Just rap -> return rap + where + toRelayAccessPoint :: DNS.Domain -> Int -> RelayAccessPoint + toRelayAccessPoint address port = + case readMaybe (unpack address) of + Nothing -> RelayAccessDomain address (fromIntegral port) + Just addr -> RelayAccessAddress addr (fromIntegral port) + instance ToJSON RelayAccessPoint where toJSON (RelayAccessDomain addr port) = object @@ -237,12 +245,3 @@ instance ToJSON RelayAccessPoint where [ "address" .= Text.pack (show ip) , "port" .= (fromIntegral port :: Int) ] - --- | Parse a address field as either an IP address or a DNS address. --- Returns corresponding RelayAccessPoint. --- -toRelayAccessPoint :: DNS.Domain -> Int -> RelayAccessPoint -toRelayAccessPoint address port = - case readMaybe (unpack address) of - Nothing -> RelayAccessDomain address (fromIntegral port) - Just addr -> RelayAccessAddress addr (fromIntegral port) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs index 02e250694d7..1ff36a9229d 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -100,7 +100,7 @@ import Ouroboros.Network.NodeToClient (NodeToClientVersion (..), import Ouroboros.Network.NodeToClient qualified as NodeToClient import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (..), NodeToNodeVersion (..), - NodeToNodeVersionData (..), RemoteAddress) + NodeToNodeVersionData (..), RemoteAddress, NetworkDNSSubscriptionTracers (ndstDnsTracer)) import Ouroboros.Network.NodeToNode qualified as NodeToNode import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers) import Ouroboros.Network.PeerSelection.Churn (PeerChurnArgs (..)) @@ -201,6 +201,8 @@ data TracersExtra ntnAddr ntnVersion ntnVersionData , dtInboundGovernorTransitionTracer :: Tracer m (RemoteTransitionTrace ntnAddr) + , dtDNSTracer :: Tracer m (DnsTrace ntnAddr) + -- -- NodeToClient tracers -- @@ -245,6 +247,7 @@ nullTracers = , dtLocalConnectionManagerTracer = nullTracer , dtLocalServerTracer = nullTracer , dtLocalInboundGovernorTracer = nullTracer + , dtDnsTracer = nullTracer } -- | P2P Arguments Extras @@ -544,7 +547,9 @@ data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData -- | diffusion dns actions -- diDnsActions - :: DNSLookupType -> DNSActions resolver resolverError m, + :: DNSLookupType + -> Tracer m (DnsTrace ntnAddr) + -> DNSActions resolver resolverError m, -- | Update `ntnVersionData` for initiator-only local roots. diUpdateVersionData @@ -659,6 +664,7 @@ runM Interfaces , dtLocalConnectionManagerTracer , dtLocalServerTracer , dtLocalInboundGovernorTracer + , dtDnsTracer } Arguments { daIPv4Address @@ -1069,7 +1075,7 @@ runM Interfaces withPeerSelectionActions' readInboundPeers = withPeerSelectionActions localRootsVar PeerActionsDNS { paToPeerAddr = diNtnToPeerAddr, - paDnsActions = diDnsActions lookupReqs, + paDnsActions = diDnsActions lookupReqs dtDnsTracer, paDnsSemaphore = dnsSemaphore } PeerSelectionActionsArgs { psLocalRootPeersTracer = dtTraceLocalRootPeersTracer, diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs index 91beb0717d3..19dcc72f165 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -13,8 +13,8 @@ #endif module Ouroboros.Network.PeerSelection.LedgerPeers - ( DomainAccessPoint (..) - , IP.IP (..) + ( --DomainAccessPoint (..) + IP.IP (..) , LedgerPeers (..) , getLedgerPeers , RelayAccessPoint (..) @@ -347,15 +347,16 @@ ledgerPeersThread PeerActionsDNS { -- 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]) + partitionPeer :: (Set peerAddr, [RelayAccessPoint]) -> RelayAccessPoint - -> (Set peerAddr, [DomainAccessPoint]) - partitionPeer (addrs, domains) (RelayDomainAccessPoint domain) = - (addrs, domain : domains) - partitionPeer (!addrs, domains) (RelayAccessAddress ip port) = - let !addr = paToPeerAddr ip port - addrs' = Set.insert addr addrs - in (addrs', domains) + -> (Set peerAddr, [RelayAccessPoint]) + partitionPeer (!addrs, domains) = \case + RelayAccessAddress ip port -> + let !addr = paToPeerAddr ip port + addrs' = Set.insert addr addrs + in (addrs', domains) + d@(RelayAccessDomain {}) -> (addrs, d : domains) + d@(RelayAccessSRVDomain {}) -> (addrs, d : domains) -- | Arguments record to stakeMapWithSlotOverSource function diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs index 4389f1f591a..f0ffe2208c4 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs @@ -44,9 +44,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] + | TraceLedgerPeersDomains [RelayAccessPoint] | TraceLedgerPeersResult DNS.Domain [(IP, DNS.TTL)] - | TraceLedgerPeersResultVia DomainSRVAccessPoint DomainPlainAccessPoint [(IP, DNS.TTL)] + | TraceLedgerPeersResultVia DNS.Domain DNS.Domain [(IP, DNS.TTL)] | TraceLedgerPeersFailure DNS.Domain (Maybe DNS.DNSError) | DisabledLedgerPeers -- ^ Trace for when getting peers from the ledger is disabled, that is DontUseLedgerPeers. @@ -102,7 +102,7 @@ instance Show TraceLedgerPeers where show (TraceLedgerPeersDomains domains) = "Resolving " ++ show domains show (TraceLedgerPeersResult domain l) = "Resolution success " ++ show domain ++ " " ++ show l - show (TraceLedgerPeersResultVia (DomainSRV dSRV) (DomainPlain dPlain _p) l) = + show (TraceLedgerPeersResultVia dSRV dPlain l) = "Resolution success " ++ show dSRV ++ " via " ++ show dPlain ++ " " ++ show l show (TraceLedgerPeersFailure domain err) = "Resolution failed " ++ show domain ++ " " ++ show err diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs index db5899a22f6..89941578bb5 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -1,5 +1,7 @@ module Ouroboros.Network.PeerSelection.RootPeersDNS ( module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + , DnsTrace (..) + , DnsPeersKind (..) , PeerActionsDNS (..) ) where diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs index b80d63c4bbd..d52de98819b 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs @@ -2,8 +2,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions ( -- * DNS based actions for local and public root providers @@ -11,6 +13,7 @@ module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions -- * DNSActions IO , ioDNSActions , DNSLookupType (..) + , DNSLookupResult -- * Utils -- ** Resource , Resource (..) @@ -20,7 +23,9 @@ module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions , dispatchLookupWithTTL -- ** Error type , DNSorIOError (..) - , DNSLookupResult (..) + -- TODO clean up + , DnsTrace (..) + , DnsPeersKind (..) ) where import Data.Foldable qualified as Fold @@ -58,6 +63,25 @@ import System.Random import Ouroboros.Network.PeerSelection.RelayAccessPoint +data DnsPeersKind = DnsLocalPeers | DnsPublicPeers | DnsLedgerPeers + +data DnsTrace addr = DnsResult + DnsPeersKind + DNS.Domain + -- ^ source of addresses + (Maybe DNS.Domain) + -- ^ SRV domain, if relevant + [(addr, PortNumber, DNS.TTL)] + | DnsError DnsPeersKind DNS.Domain DNS.DNSError + | DnsSRVFail DnsPeersKind DNS.Domain + -- DnsTraceLookupException SomeException + -- | DnsTraceLookupAError DNS.DNSError + -- | DnsTraceLookupAAAAError DNS.DNSError + -- | DnsTraceLookupIPv6First + -- | DnsTraceLookupIPv4First + -- | DnsTraceLookupAResult [Socket.SockAddr] + -- | DnsTraceLookupAAAAResult [Socket.SockAddr] + data DNSLookupType = LookupReqAOnly | LookupReqAAAAOnly | LookupReqAAndAAAA @@ -71,15 +95,8 @@ data DNSorIOError exception -- | The type returned by 'DNSActions.dnsLookupWithTTL' -- indicating the type of domain attempted to resolve -- -data DNSLookupResult peeraddr = - DNSLookup ( DomainPlainAccessPoint - , [DNSError] - , [(peeraddr, DNS.TTL)]) - | DNSLookupSRV ( DomainSRVAccessPoint - , [DNSError] - , Maybe ( DomainPlainAccessPoint - , [(peeraddr, DNS.TTL)])) - deriving (Show) +type DNSLookupResult peeraddr = + Either [DNS.DNSError] [(peeraddr, PortNumber, DNS.TTL)] instance Exception exception => Exception (DNSorIOError exception) where @@ -191,7 +208,8 @@ data DNSActions resolver exception m = DNSActions { -- DNS library timeouts do not work reliably on Windows (#1873), hence the -- additional timeout. -- - dnsLookupWithTTL :: DomainAccessPoint + dnsLookupWithTTL :: DnsPeersKind + -> RelayAccessPoint -> DNS.ResolvConf -> resolver -> StdGen @@ -220,13 +238,14 @@ getResolver resolvConf = do -- It guarantees that returned TTLs are strictly greater than 0. -- ioDNSActions :: DNSLookupType + -> Tracer IO (DnsTrace IP) -> DNSActions DNS.Resolver IOException IO -ioDNSActions = - \reqs -> DNSActions { - dnsResolverResource = resolverResource, - dnsAsyncResolverResource = asyncResolverResource, - dnsLookupWithTTL = dispatchLookupWithTTL reqs mkIOAction - } +ioDNSActions lookupType tracer = + DNSActions { + dnsResolverResource = resolverResource, + dnsAsyncResolverResource = asyncResolverResource, + dnsLookupWithTTL = dispatchLookupWithTTL lookupType mkIOAction tracer + } where mkIOAction resolver resolvConf domain ofType = timeout (microsecondsAsIntToDiffTime @@ -344,53 +363,62 @@ ioDNSActions = srvRecordLookupWithTTL :: forall m. (MonadAsync m) - => DNSLookupType - -> DNS.Domain - -> ( DNS.Domain - -> DNS.TYPE - -> m (Maybe (Either DNSError DNSMessage))) - -> StdGen - -> m (DNSLookupResult IP) -srvRecordLookupWithTTL ofType domain0 mkAction2 rng = do + => DNSLookupType + -> Tracer m (DnsTrace IP) + -> DnsPeersKind + -> DNS.Domain + -> ( DNS.Domain + -> DNS.TYPE + -> m (Maybe (Either DNSError DNSMessage))) + -> StdGen + -> m (DNSLookupResult IP) +srvRecordLookupWithTTL ofType tracer peerType domain0 mkAction2 rng = do reply <- mkAction2 domain0 DNS.SRV case reply of - Nothing -> return $ DNSLookupSRV (srvDomain, [DNS.TimeoutExpired], Nothing) - Just (Left err) -> return $ DNSLookupSRV (srvDomain, [err], Nothing) + Nothing -> do + traceWith tracer $ DnsError peerType domain0 DNS.TimeoutExpired + return . Left $ [DNS.TimeoutExpired] + Just (Left err) -> do + traceWith tracer $ DnsError peerType domain0 err + return . Left $ [err] Just (Right msg) -> case DNS.fromDNSMessage msg selectSRV of - Left err -> return $ DNSLookupSRV (srvDomain, [err], Nothing) + Left err -> do + traceWith tracer $ DnsError peerType domain0 err + return . Left $ [err] Right services -> do let srvByPriority = sortOn priority services grouped = NE.groupWith priority srvByPriority - - case listToMaybe grouped of - Just topPriority -> do - case topPriority of - (domain, _, _, port) NE.:| [] -> -- fast path - DNSLookupSRV - . annotateDomainAndPort domain port <$> - domainLookupWithTTL ofType (mkAction2 domain) - many -> -- general path - DNSLookupSRV <$> runWeightedLookup many - Nothing -> - -- this shouldn't happen in practice, and so should - -- this be an error? It is convenient for some DNS tests - -- to observe a DNS lookup attempt even though it will lead nowhere. - return $ DNSLookupSRV (srvDomain, [], Nothing) + (result, domain) <- do + case listToMaybe grouped of + Just topPriority -> + case topPriority of + (domain, _, _, port) NE.:| [] -> do -- fast path + result <- domainLookupWithTTL tracer ofType domain peerType mkAction2 + let result' = ipsttlsWithPort port <$> result + return (result', domain) + many -> -- general path + runWeightedLookup many + Nothing -> return (Right [], "") + case result of + Left {} -> traceWith tracer $ DnsSRVFail peerType domain0 + Right ipsttls -> + traceWith tracer $ DnsResult peerType domain (Just domain0) ipsttls + return result where - srvDomain = DomainSRV domain0 - annotateDomainAndPort domain !port (e, ipsttls) = (srvDomain, e, Just (DomainPlain domain (fromIntegral port), ipsttls)) - + ipsttlsWithPort port = map (\(ip, ttl) -> (ip, fromIntegral port, ttl)) runWeightedLookup :: NonEmpty (DNS.Domain, Word16, Word16, Word16) - -> m (DomainSRVAccessPoint, [DNSError], Maybe (DomainPlainAccessPoint, [(IP, DNS.TTL)])) + -> m (DNSLookupResult IP, DNS.Domain) runWeightedLookup services = let (upperBound, cdf) = Fold.foldl' aggregate (0, []) services mapCdf = Map.fromList cdf (pick, _) = randomR (0, upperBound) rng (domain, _, _, port) = snd . fromJust $ Map.lookupGE pick mapCdf - in annotateDomainAndPort domain port <$> - domainLookupWithTTL ofType (mkAction2 domain) + complete = ipsttlsWithPort port + in (,domain) + <$> (fmap complete <$> domainLookupWithTTL tracer ofType domain peerType mkAction2) + aggregate (!upper, cdf) srv = let upper' = weight srv + upper @@ -413,45 +441,63 @@ dispatchLookupWithTTL :: (MonadAsync m) -> DNS.Domain -> DNS.TYPE -> m (Maybe (Either DNSError DNSMessage))) - -> DomainAccessPoint + -> Tracer m (DnsTrace IP) + -> DnsPeersKind + -> RelayAccessPoint -> resolvConf -> resolver -> StdGen -> m (DNSLookupResult IP) -dispatchLookupWithTTL lookupType mkAction4 domain conf resolver rng = +dispatchLookupWithTTL lookupType mkAction4 tracer peerType domain conf resolver rng = let mkAction2 = mkAction4 resolver conf in case domain of - DomainAccessPoint d -> push <$> domainLookupWithTTL lookupType (mkAction2 dapDomain) - where - DomainPlain { dapDomain } = d - push (a, b) = DNSLookup (d, a, b) - DomainSRVAccessPoint d -> srvRecordLookupWithTTL lookupType (srvDomain d) mkAction2 rng + RelayAccessDomain d p -> do + result <- domainLookupWithTTL tracer lookupType d peerType mkAction2 + let result' = map (\(ip, ttl) -> (ip, p, ttl)) <$> result + Fold.traverse_ (traceWith tracer . DnsResult peerType d Nothing) result' + return result' + RelayAccessSRVDomain d -> srvRecordLookupWithTTL lookupType tracer peerType d mkAction2 rng + RelayAccessAddress addr p -> return . Right $ [(addr, p, maxBound)] domainLookupWithTTL :: (MonadAsync m) - => DNSLookupType - -> ( DNS.TYPE + => Tracer m (DnsTrace addr) + -> DNSLookupType + -> DNS.Domain + -> DnsPeersKind + -> ( DNS.Domain + -> DNS.TYPE -> m (Maybe (Either DNSError DNSMessage))) - -> m ([DNS.DNSError], [(IP, DNS.TTL)]) -domainLookupWithTTL LookupReqAOnly action1 = do - res <- domainALookupWithTTL (action1 DNS.A) + -> m (Either [DNSError] [(IP, DNS.TTL)]) +domainLookupWithTTL tracer LookupReqAOnly d peerType action2 = do + res <- domainALookupWithTTL (action2 d DNS.A) case res of - Left err -> return ([err], []) - Right r -> return ([], r) + Left err -> do + traceWith tracer $ DnsError peerType d err + return . Left $ [err] + Right r -> return . Right $ r -domainLookupWithTTL LookupReqAAAAOnly action1 = do - res <- domainAAAALookupWithTTL (action1 DNS.AAAA) +domainLookupWithTTL tracer LookupReqAAAAOnly d peerType action2 = do + res <- domainAAAALookupWithTTL (action2 d DNS.AAAA) case res of - Left err -> return ([err], []) - Right r -> return ([], r) - -domainLookupWithTTL LookupReqAAndAAAA action1 = do - (r_ipv6, r_ipv4) <- concurrently (domainAAAALookupWithTTL (action1 DNS.AAAA)) - (domainALookupWithTTL (action1 DNS.A)) + Left err -> do + traceWith tracer $ DnsError peerType d err + return . Left $ [err] --([err], []) + Right r -> return . Right $ r + +domainLookupWithTTL tracer LookupReqAAndAAAA d peerType action2 = do + (r_ipv6, r_ipv4) <- concurrently (domainAAAALookupWithTTL (action2 d DNS.AAAA)) + (domainALookupWithTTL (action2 d DNS.A)) case (r_ipv6, r_ipv4) of - (Left e6, Left e4) -> return ([e6, e4], []) - (Right r6, Left e4) -> return ([e4], r6) - (Left e6, Right r4) -> return ([e6], r4) - (Right r6, Right r4) -> return ([], r6 <> r4) + (Left e6, Left e4) -> do + mapM_ (traceWith tracer . DnsError peerType d) [e6, e4] + return . Left $ [e6, e4] + (Right r6, Left e4) -> do + traceWith tracer $ DnsError peerType d e4 + return . Right $ r6 + (Left e6, Right r4) -> do + traceWith tracer $ DnsError peerType d e6 + return . Right $ r4 + (Right r6, Right r4) -> return . Right $ r6 <> r4 -- | Like 'DNS.lookupA' but also return the TTL for the results. -- diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LedgerPeers.hs index bfdb3c8d68f..bf2723c0e85 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LedgerPeers.hs @@ -3,17 +3,19 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers (resolveLedgerPeers) where -import Control.Monad (when) +-- import Control.Monad (when) import Control.Monad.Class.MonadAsync import Control.Tracer (Tracer, traceWith) +import Data.List (foldl') import Data.IP qualified as IP import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Foldable (foldlM) +-- import Data.Foldable (foldlM) import Data.Set (Set) import Data.Set qualified as Set @@ -46,9 +48,9 @@ resolveLedgerPeers -> DNSSemaphore m -> DNS.ResolvConf -> DNSActions resolver exception m - -> [DomainAccessPoint] + -> [RelayAccessPoint] -> StdGen - -> m (Map DomainAccessPoint (Set peerAddr)) + -> m (Map DNS.Domain (Set peerAddr)) resolveLedgerPeers tracer toPeerAddr dnsSemaphore @@ -67,7 +69,7 @@ resolveLedgerPeers tracer where resolveDomains :: StrictTVar m (Resource m (Either (DNSorIOError exception) resolver)) - -> m (Map DomainAccessPoint (Set peerAddr)) + -> m (Map DNS.Domain (Set peerAddr)) resolveDomains resourceVar = do rr <- readTVarIO resourceVar (er, rr') <- withResource rr @@ -77,63 +79,46 @@ resolveLedgerPeers tracer Left (IOError err) -> throwIO err Right resolver -> do let lookups = - [ withDNSSemaphore dnsSemaphore + [ (domain',) <$> withDNSSemaphore dnsSemaphore (dnsLookupWithTTL + DnsLedgerPeers domain resolvConf resolver rng) - | domain <- domains ] + | domain <- domains + , Just domain' <- + case domain of + RelayAccessAddress {} -> [Nothing] + RelayAccessDomain d _p -> [Just d] + RelayAccessSRVDomain d -> [Just d] + ] -- 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 + return $ foldl' processResult Map.empty results - processResult :: Map DomainAccessPoint (Set peerAddr) - -> DNSLookupResult IP - -> m (Map DomainAccessPoint (Set peerAddr)) - processResult mr (DNSLookup (domain@DomainPlain { dapDomain, dapPortNumber } - , errs - , ipsttls)) = do - mapM_ (traceWith tracer . TraceLedgerPeersFailure dapDomain . Just) - errs - when (not $ null ipsttls) $ - traceWith tracer $ TraceLedgerPeersResult dapDomain ipsttls + processResult :: Map DNS.Domain (Set peerAddr) + -> (DNS.Domain, DNSLookupResult IP) + -> Map DNS.Domain (Set peerAddr) + processResult mr (domain , ipsttls) = do + Map.alter (addFn ipsttls) domain mr - return $ Map.alter (addFn ipsttls dapPortNumber) (DomainAccessPoint domain) mr - - processResult mr (DNSLookupSRV (domain0, errs, mResult)) = do - let domain0' = DomainSRVAccessPoint domain0 - case mResult of - Nothing -> do - if null errs - then traceWith tracer $ TraceLedgerPeersFailure (srvDomain domain0) Nothing - else - mapM_ (traceWith tracer . TraceLedgerPeersFailure (srvDomain domain0) . Just) - errs - return $ - Map.insertWith const domain0' Set.empty mr - Just (dFollow@(DomainPlain dPlain port), ipsttls) -> do - mapM_ (traceWith tracer . TraceLedgerPeersFailure dPlain . Just) - errs - when (not . null $ ipsttls) $ - traceWith tracer $ TraceLedgerPeersResultVia domain0 dFollow ipsttls - return $ Map.alter (addFn ipsttls port) domain0' mr - - addFn :: [(IP, DNS.TTL)] - -> PortNumber + addFn :: DNSLookupResult IP -> Maybe (Set peerAddr) -> Maybe (Set peerAddr) - addFn ipsttls port Nothing = - let ips = map fst ipsttls - !addrs = map (\ip -> toPeerAddr ip port) + addFn (Left _) Nothing = Just Set.empty + addFn (Left _) addrs = addrs + addFn (Right ipsttls) Nothing = + let ips = map (\(ip, port, _ttl) -> (ip, port)) ipsttls + !addrs = map (uncurry toPeerAddr) ips !addrSet = Set.fromList addrs in Just addrSet - addFn ipsttls port (Just addrSet) = - let ips = map fst ipsttls - !addrs = map (\ip -> toPeerAddr ip port) + addFn (Right ipsttls) (Just addrSet) = + let ips = map (\(ip, port, _ttl) -> (ip, port)) ipsttls + !addrs = map (uncurry toPeerAddr) ips !addrSet' = Set.union addrSet (Set.fromList addrs) in Just addrSet' diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs index f81b8b77279..8539a38cadb 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs @@ -43,22 +43,22 @@ import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRo data TraceLocalRootPeers peerAddr exception = TraceLocalRootDomains (LocalRootPeers.Config RelayAccessPoint) -- ^ 'Int' is the configured valency for the local producer groups - | TraceLocalRootWaiting DomainAccessPoint DiffTime - | TraceLocalRootResult DomainPlainAccessPoint [(IP, DNS.TTL)] - | TraceLocalRootResultVia DomainSRVAccessPoint DomainPlainAccessPoint [(IP, DNS.TTL)] + | TraceLocalRootWaiting RelayAccessPoint DiffTime + -- | TraceLocalRootResult DomainPlainAccessPoint [(IP, DNS.TTL)] + -- | TraceLocalRootResultVia DomainSRVAccessPoint DomainPlainAccessPoint [(IP, DNS.TTL)] | TraceLocalRootGroups (LocalRootPeers.Config peerAddr) -- ^ This traces the results of the local root peer provider - | TraceLocalRootDNSMap (Map DomainAccessPoint [peerAddr]) + | TraceLocalRootDNSMap (Map RelayAccessPoint [peerAddr]) -- ^ This traces the results of the domain name resolution | TraceLocalRootReconfigured (LocalRootPeers.Config RelayAccessPoint) -- ^ Old value (LocalRootPeers.Config RelayAccessPoint) -- ^ New value - | TraceLocalRootFailure DomainAccessPoint (Maybe (DNSorIOError exception)) - | TraceLocalRootFailureVia DomainSRVAccessPoint DomainPlainAccessPoint (Maybe (DNSorIOError exception)) + | TraceLocalRootFailure RelayAccessPoint (DNSorIOError exception) + -- | TraceLocalRootFailureVia DomainSRVAccessPoint DomainPlainAccessPoint (Maybe (DNSorIOError exception)) -- ^ A failure in practice should always return a @Just 'DNSorIOError'@ -- for a /well behaved/ dns implementation. But it is convenient for some -- tests to return Nothing here to observe a lookup attempt. --TODO: classify DNS errors, config error vs transitory - | TraceLocalRootError DomainAccessPoint SomeException + | TraceLocalRootError DNS.Domain SomeException deriving Show -- | Resolve 'RelayAddress'-es of local root peers using dns if needed. Local @@ -117,13 +117,17 @@ localRootPeersProvider tracer let -- Get only DomainAccessPoint to monitor and perform DNS resolution -- on them. - domains :: [DomainAccessPoint] - domains = [ domain + domains :: [RelayAccessPoint] + domains = [ rap | (_, _, m) <- serviceGroups - , (RelayDomainAccessPoint domain, _) <- Map.toList m ] + , (rap, _) <- Map.toList m + , case rap of + RelayAccessAddress {} -> False + _otherwise -> True + ] -- Initial DNS Domain Map has all domains entries empty - initialDNSDomainMap :: Map DomainAccessPoint [peerAddr] + initialDNSDomainMap :: Map RelayAccessPoint [peerAddr] initialDNSDomainMap = Map.fromList $ map (, []) domains @@ -170,56 +174,6 @@ localRootPeersProvider tracer -- all the monitoring threads are killed. loop rng' dnsSemaphore domainsGroups' - resolveDomain - :: DNSSemaphore m - -> resolver - -> DomainAccessPoint - -> StdGen - -> m (Either [DNS.DNSError] [(peerAddr, DNS.TTL)]) - resolveDomain dnsSemaphore resolver - domain0 rng = do - reply <- withDNSSemaphore dnsSemaphore - (dnsLookupWithTTL - domain0 - resolvConf - resolver - rng) - - -- the test 'prop_diffusion_dns_can_recover' requires us to be careful on how domain lookup - -- can fail, slightly complicating this code vs. legacy non-SRV implementation. Concretely, - -- the both the failure and results indicate whether an SRV lookup was attempted (the Via constructor) - -- We don't have these tests for public/ledger peers and the associated logic like this below is simpler; - -- however, the same lookup code is leveraged there and so being more explicit here alone should be sufficient. - case reply of - DNSLookup (dPlain@(DomainPlain _d port), errs, ipsttls) -> do - mapM_ (traceWith tracer . TraceLocalRootFailure (DomainAccessPoint dPlain) . Just . DNSError) - errs - let result = completion port ipsttls errs - when (isRight result) $ traceWith tracer $ TraceLocalRootResult dPlain ipsttls - return result - DNSLookupSRV (dSRV, errs, mAnswer) -> - case mAnswer of - Nothing -> do - if null errs - then traceWith tracer $ TraceLocalRootFailure (DomainSRVAccessPoint dSRV) Nothing - else - mapM_ (traceWith tracer . TraceLocalRootFailure (DomainSRVAccessPoint dSRV) . Just . DNSError) - errs - return $ Left [] - Just (dFollow@(DomainPlain _d port), ipsttls) -> do - mapM_ (traceWith tracer . TraceLocalRootFailureVia dSRV dFollow . Just . DNSError) - errs - let result = completion port ipsttls errs - when (isRight result) $ traceWith tracer $ TraceLocalRootResultVia dSRV dFollow ipsttls - return result - where - completion port ipsttls errs = - if not . null $ ipsttls then do - Right [ ( toPeerAddr addr port - , _ttl) - | (addr, _ttl) <- ipsttls ] - else do - Left errs -- | Function that runs on a monitoring thread. This function will, every -- TTL, issue a DNS resolution request and collect the results for its @@ -230,16 +184,21 @@ localRootPeersProvider tracer monitorDomain :: Resource m (Either (DNSorIOError exception) resolver) -> DNSSemaphore m - -> StrictTVar m (Map DomainAccessPoint [peerAddr]) + -> StrictTVar m (Map RelayAccessPoint [peerAddr]) -> StdGen - -> DomainAccessPoint - -> (DomainAccessPoint, m Void) - monitorDomain rr0 dnsSemaphore dnsDomainMapVar resolvRng0 domain = - (domain, go 0 resolvRng0 - (retryResource ((TraceLocalRootFailure domain . Just) `contramap` tracer) + -> RelayAccessPoint + -> (DNS.Domain, m Void) + monitorDomain rr0 dnsSemaphore dnsDomainMapVar resolvRng0 domain = + (domain', go 0 resolvRng0 + (retryResource (TraceLocalRootFailure domain `contramap` tracer) (1 :| [3, 6, 9, 12]) rr0)) where + domain' = case domain of + RelayAccessDomain d _p -> d + RelayAccessSRVDomain d -> d + _otherwise -> error "LocalRootPeers.monitorDomain: impossible!" + go :: DiffTime -> StdGen -> Resource m resolver @@ -253,9 +212,18 @@ localRootPeersProvider tracer --- Resolve 'domain' let (rng', _) = split rng - reply <- resolveDomain dnsSemaphore resolver domain rng + reply <- fmap ((\(ip, port, ttl) -> (toPeerAddr ip port, ttl)) <$>) <$> + withDNSSemaphore dnsSemaphore + (dnsLookupWithTTL + DnsLocalPeers + domain + resolvConf + resolver + rng) + case reply of Left errs + -- TODO cleanup | [] <- errs -> go (ttlBackoff ttl) rng' rr' | otherwise -> go (minimum $ map (\err -> ttlForDnsError err ttl) errs) @@ -303,7 +271,7 @@ localRootPeersProvider tracer -- It does so by reading a DNS Domain Map and replacing all instances of a -- DomainAccessPoint in the static configuration with the values from the -- map. - getLocalRootPeersGroups :: Map DomainAccessPoint [peerAddr] + getLocalRootPeersGroups :: Map RelayAccessPoint [peerAddr] -> [( HotValency , WarmValency , Map RelayAccessPoint LocalRootConfig)] @@ -324,11 +292,10 @@ localRootPeersProvider tracer -> case rap of RelayAccessAddress ip port -> Map.insert (toPeerAddr ip port) pa accMap - RelayDomainAccessPoint dap -> - let newEntries = maybe Map.empty - Map.fromList - $ fmap (, pa) - <$> Map.lookup dap dnsMap + dap -> + let newEntries = + maybe Map.empty (Map.fromList . fmap (, pa)) + $ Map.lookup dap dnsMap in accMap <> newEntries ) Map.empty diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/PublicRootPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/PublicRootPeers.hs index 93977e1b118..6464a74e18b 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/PublicRootPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/PublicRootPeers.hs @@ -40,10 +40,10 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore (DNSSemaphore, data TracePublicRootPeers = TracePublicRootRelayAccessPoint (Map RelayAccessPoint PeerAdvertise) - | TracePublicRootDomains [DomainAccessPoint] - | TracePublicRootResult DNS.Domain [(IP, TTL)] - | TracePublicRootResultVia DomainSRVAccessPoint DNS.Domain [(IP, TTL)] - | TracePublicRootFailure DomainAccessPoint (Maybe DNSError) + | TracePublicRootDomains [RelayAccessPoint] + -- | TracePublicRootResult DNS.Domain [(IP, TTL)] + -- | TracePublicRootResultVia DomainSRVAccessPoint DNS.Domain [(IP, TTL)] + -- | TracePublicRootFailure DomainAccessPoint (Maybe DNSError) --TODO: classify DNS errors, config error vs transitory deriving Show @@ -79,33 +79,33 @@ publicRootPeersProvider tracer resourceVar <- newTVarIO rr action (requestPublicRootPeers resourceVar) where - processResult :: (DNSLookupResult IP, PeerAdvertise) - -> m ((Maybe PortNumber, PeerAdvertise), [(IP, TTL)]) - processResult (DNSLookup (dPlain@(DomainPlain domain port), errs, ipsttls) - , pa) = do - mapM_ (traceWith tracer . TracePublicRootFailure dap . Just) - errs - when (not . null $ ipsttls) $ - traceWith tracer $ TracePublicRootResult domain ipsttls - - return ((Just port, pa), ipsttls) - where - dap = DomainAccessPoint dPlain - - processResult ( DNSLookupSRV (srvDomain, errs, mResult) - , pa) = do - mapM_ (traceWith tracer . TracePublicRootFailure (DomainSRVAccessPoint srvDomain) . Just) - errs - - case mResult of - Nothing -> do - when (null errs) $ - traceWith tracer $ TracePublicRootFailure (DomainSRVAccessPoint srvDomain) Nothing - return ((Nothing, pa), []) - Just (DomainPlain dFollow port, ipsttls) -> do - when (not . null $ ipsttls) $ - traceWith tracer $ TracePublicRootResultVia srvDomain dFollow ipsttls - return ((Just port, pa), ipsttls) + -- processResult :: (DNSLookupResult IP, DNS.Domain, PeerAdvertise) + -- -> m (PeerAdvertise, [(IP, PortNumber, TTL)]) + -- processResult (DNSLookup (dPlain@(DomainPlain domain port), errs, ipsttls) + -- , pa) = do + -- -- mapM_ (traceWith tracer . TracePublicRootFailure dap . Just) + -- -- errs + -- -- when (not . null $ ipsttls) $ + -- -- traceWith tracer $ TracePublicRootResult domain ipsttls + + -- return ((Just port, pa), ipsttls) + -- where + -- dap = DomainAccessPoint dPlain + + -- processResult ( DNSLookupSRV (srvDomain, errs, mResult) + -- , pa) = do + -- mapM_ (traceWith tracer . TracePublicRootFailure (DomainSRVAccessPoint srvDomain) . Just) + -- errs + + -- case mResult of + -- Nothing -> do + -- when (null errs) $ + -- traceWith tracer $ TracePublicRootFailure (DomainSRVAccessPoint srvDomain) Nothing + -- return ((Nothing, pa), []) + -- Just (DomainPlain dFollow port, ipsttls) -> do + -- when (not . null $ ipsttls) $ + -- traceWith tracer $ TracePublicRootResultVia srvDomain dFollow ipsttls + -- return ((Just port, pa), ipsttls) requestPublicRootPeers :: StrictTVar m (Resource m (Either (DNSorIOError exception) resolver)) @@ -123,27 +123,32 @@ publicRootPeersProvider tracer Right resolver -> do let (doms, relayAddrs) = flip partition (Map.assocs services) $ \case - (RelayDomainAccessPoint {}, _) -> True - _otherwise -> False + (RelayAccessAddress {}, _) -> False + _otherwise -> True lookups = [ (, pa) <$> withDNSSemaphore dnsSemaphore (dnsLookupWithTTL - dap + DnsPublicPeers + domain resolvConf resolver rng0) - | (RelayDomainAccessPoint dap, pa) <- doms] + | (domain, pa) <- doms + , case domain of + RelayAccessAddress {} -> False + RelayAccessDomain {} -> True + RelayAccessSRVDomain {} -> True + ] -- 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 port, pa) , ipttl) - | ( (Just port, pa) - , ipttls) <- results' - , (ip, ipttl) <- ipttls + | ( Right ipsttls + , pa) <- results + , (ip, port, ipttl) <- ipsttls ] !domainsIps = [(toPeerAddr ip port, pa) | (RelayAccessAddress ip port, pa) <- relayAddrs ]