Skip to content

Commit

Permalink
Merge #3489
Browse files Browse the repository at this point in the history 
3489: DNS support for IPv6 r=karknu a=karknu

A dupe of #3447 which was lost when p2p-master was merged.

Co-authored-by: Karl Knutsson <[email protected]>
  • Loading branch information
@iohk-bors @karknu
iohk-bors[bot] and karknu authored Nov 17, 2021
2 parents 26c0747 + b9e0b9d commit a75771f
Show file tree
Hide file tree
Showing 6 changed files with 172 additions and 97 deletions.
26 changes: 18 additions & 8 deletions ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -100,6 +100,7 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS
( resolveDomainAccessPoint
, DNSActions
, ioDNSActions
, LookupReqs (..)
, DomainAccessPoint
, RelayAccessPoint(..)
, TraceLocalRootPeers(..)
Expand Down Expand Up @@ -538,7 +539,7 @@ data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData
-- | node-to-node domain resolver
--
diNtnDomainResolver
:: [DomainAccessPoint] -> m (Map DomainAccessPoint (Set ntnAddr)),
:: LookupReqs -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set ntnAddr)),

-- | node-to-client snocket
--
Expand Down Expand Up @@ -571,7 +572,7 @@ data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData
-- | diffusion dns actions
--
diDnsActions
:: DNSActions resolver resolverError m
:: LookupReqs -> DNSActions resolver resolverError m
}

runM
Expand Down Expand Up @@ -713,6 +714,13 @@ runM Interfaces
-> throwIO (UnexpectedIPv6Address addr)
Nothing -> pure ()

lookupReqs <- case (cmIPv4Address, cmIPv6Address) of
(Just _, Nothing) -> return LookupReqAOnly
(Nothing, Just _) -> return LookupReqAAAAOnly
(Just _, Just _) -> return LookupReqAAndAAAA
_ ->
throwIO (NoSocket :: Failure RemoteAddress)

-- control channel for the server; only required in
-- @'InitiatorResponderMode' :: 'MuxMode'@
cmdInMode
Expand Down Expand Up @@ -836,7 +844,7 @@ runM Interfaces
dtLedgerPeersTracer
daReadUseLedgerAfter
daLedgerPeersCtx
diNtnDomainResolver
(diNtnDomainResolver lookupReqs)
$ \requestLedgerPeers ledgerPeerThread ->
case cmdInMode of
-- InitiatorOnlyMode
Expand Down Expand Up @@ -921,7 +929,7 @@ runM Interfaces
dtTraceLocalRootPeersTracer
dtTracePublicRootPeersTracer
diNtnToPeerAddr
diDnsActions
(diDnsActions lookupReqs)
(readTVar peerSelectionTargetsVar)
daReadLocalRootPeers
daReadPublicRootPeers
Expand Down Expand Up @@ -1043,7 +1051,7 @@ runM Interfaces
dtTraceLocalRootPeersTracer
dtTracePublicRootPeersTracer
diNtnToPeerAddr
diDnsActions
(diDnsActions lookupReqs)
(readTVar peerSelectionTargetsVar)
daReadLocalRootPeers
daReadPublicRootPeers
Expand Down Expand Up @@ -1299,13 +1307,14 @@ run tracers tracersExtra args argsExtra apps appsExtra = do
#else
diInstallSigUSR1Handler = \_ -> pure ()
#endif
diNtnDomainResolver :: [DomainAccessPoint]

let diNtnDomainResolver :: LookupReqs -> [DomainAccessPoint]
-> IO (Map DomainAccessPoint (Set Socket.SockAddr))
diNtnDomainResolver =
diNtnDomainResolver lr =
resolveDomainAccessPoint
(dtTracePublicRootPeersTracer tracersExtra)
DNS.defaultResolvConf
ioDNSActions
(ioDNSActions lr)

diRng <- newStdGen
runM
Expand All @@ -1327,6 +1336,7 @@ run tracers tracersExtra args argsExtra apps appsExtra = do
}
tracers tracersExtra args argsExtra apps appsExtra


--
-- Data flow
--
Expand Down
111 changes: 58 additions & 53 deletions ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,7 @@ module Ouroboros.Network.PeerSelection.RootPeersDNS (
constantResource,
-- ** DNSActions IO
ioDNSActions,
LookupReqs (..),

-- * DNS based provider for local root peers
localRootPeersProvider,
Expand All @@ -38,8 +39,9 @@ module Ouroboros.Network.PeerSelection.RootPeersDNS (
Socket.PortNumber,
) where

import Data.Foldable (foldlM)
import Data.Word (Word32)
import Data.List (elemIndex, foldl')
import Data.List (elemIndex)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Set as Set
import Data.Set (Set)
Expand All @@ -59,7 +61,6 @@ import Control.Monad.Class.MonadThrow
import Control.Tracer (Tracer(..), contramap, traceWith)


import Data.IP (IPv4)
import qualified Data.IP as IP
import qualified Network.DNS as DNS
import qualified Network.Socket as Socket
Expand All @@ -69,6 +70,7 @@ import Ouroboros.Network.PeerSelection.RelayAccessPoint
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
( DNSorIOError (..)
, DNSActions (..)
, LookupReqs (..)
, Resource (..)
, ioDNSActions
, constantResource
Expand All @@ -83,7 +85,7 @@ data TraceLocalRootPeers peerAddr exception =
TraceLocalRootDomains [(Int, Map RelayAccessPoint PeerAdvertise)]
-- ^ 'Int' is the configured valency for the local producer groups
| TraceLocalRootWaiting DomainAccessPoint DiffTime
| TraceLocalRootResult DomainAccessPoint [(IPv4, DNS.TTL)]
| TraceLocalRootResult DomainAccessPoint [(IP, DNS.TTL)]
| TraceLocalRootGroups (Seq (Int, Map peerAddr PeerAdvertise))
-- ^ This traces the results of the local root peer provider
| TraceLocalRootFailure DomainAccessPoint (DNSorIOError exception)
Expand Down Expand Up @@ -117,7 +119,7 @@ localRootPeersProvider tracer
resolvConf
DNSActions {
dnsAsyncResolverResource,
dnsLookupAWithTTL
dnsLookupWithTTL
}
readDomainsGroups
rootPeersGroupsVar =
Expand Down Expand Up @@ -194,22 +196,22 @@ localRootPeersProvider tracer
:: resolver
-> DomainAccessPoint
-> PeerAdvertise
-> m (Either DNS.DNSError [((peerAddr, PeerAdvertise), DNS.TTL)])
-> m (Either [DNS.DNSError] [((peerAddr, PeerAdvertise), DNS.TTL)])
resolveDomain resolver
domain@DomainAccessPoint {dapDomain, dapPortNumber}
advertisePeer = do
reply <- dnsLookupAWithTTL resolvConf resolver dapDomain
case reply of
Left err -> do
traceWith tracer (TraceLocalRootFailure domain (DNSError err))
return $ Left err

Right results -> do
traceWith tracer (TraceLocalRootResult domain results)
return $ Right [ (( toPeerAddr (IP.IPv4 addr) dapPortNumber
, advertisePeer)
, _ttl)
| (addr, _ttl) <- results ]
(errs, results) <- dnsLookupWithTTL resolvConf resolver dapDomain
mapM_ (traceWith tracer . TraceLocalRootFailure domain . DNSError)
errs

if null results
then return $ Left errs
else do
traceWith tracer (TraceLocalRootResult domain results)
return $ Right [ (( toPeerAddr addr dapPortNumber
, advertisePeer)
, _ttl)
| (addr, _ttl) <- results ]

monitorDomain
:: Resource m (DNSorIOError exception) resolver
Expand All @@ -236,7 +238,8 @@ localRootPeersProvider tracer

reply <- resolveDomain resolver domain advertisePeer
case reply of
Left err -> go rrNext rootPeersGroups (ttlForDnsError err ttl)
Left errs -> go rrNext rootPeersGroups
(minimum $ map (\err -> ttlForDnsError err ttl) errs)
Right results -> do
rootPeersGroups' <- atomically $ do
let (target, entry) = rootPeersGroups `Seq.index` index
Expand All @@ -263,7 +266,7 @@ localRootPeersProvider tracer
data TracePublicRootPeers =
TracePublicRootRelayAccessPoint [RelayAccessPoint]
| TracePublicRootDomains [DomainAccessPoint]
| TracePublicRootResult DNS.Domain [(IPv4, DNS.TTL)]
| TracePublicRootResult DNS.Domain [(IP, DNS.TTL)]
| TracePublicRootFailure DNS.Domain DNS.DNSError
--TODO: classify DNS errors, config error vs transitory
deriving Show
Expand All @@ -288,7 +291,7 @@ publicRootPeersProvider tracer
readDomains
DNSActions {
dnsResolverResource,
dnsLookupAWithTTL
dnsLookupWithTTL
}
action = do
domains <- atomically readDomains
Expand All @@ -297,6 +300,16 @@ publicRootPeersProvider tracer
resourceVar <- newTVarIO rr
action (requestPublicRootPeers resourceVar)
where
processResult :: (DomainAccessPoint, ([DNS.DNSError], [(IP, DNS.TTL)]))
-> m (DomainAccessPoint, [(IP, DNS.TTL)])
processResult (domain, (errs, result)) = do
mapM_ (traceWith tracer . TracePublicRootFailure (dapDomain domain))
errs
when (not $ null result) $
traceWith tracer $ TracePublicRootResult (dapDomain domain) result

return (domain, result)

requestPublicRootPeers
:: StrictTVar m (Resource m (DNSorIOError exception) resolver)
-> Int
Expand All @@ -313,24 +326,20 @@ publicRootPeersProvider tracer
Right resolver -> do
let lookups =
[ (,) (DomainAccessPoint domain port)
<$> dnsLookupAWithTTL
<$> dnsLookupWithTTL
resolvConf
resolver
domain
| RelayAccessDomain domain port <- domains ]
-- The timeouts here are handled by the 'lookupAWithTTL'. They're
-- 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)
sequence_
[ traceWith tracer $ case result of
Left dnserr -> TracePublicRootFailure dapDomain dnserr
Right ipttls -> TracePublicRootResult dapDomain ipttls
| (DomainAccessPoint {dapDomain}, result) <- results ]
let successes = [ ( toPeerAddr (IP.IPv4 ip) dapPortNumber
results' <- mapM processResult results
let successes = [ ( toPeerAddr ip dapPortNumber
, ipttl)
| ( DomainAccessPoint {dapPortNumber}
, Right ipttls) <- results
, ipttls) <- results'
, (ip, ipttl) <- ipttls
]
!domainsIps = [toPeerAddr ip port
Expand All @@ -355,7 +364,7 @@ resolveDomainAccessPoint tracer
resolvConf
DNSActions {
dnsResolverResource,
dnsLookupAWithTTL
dnsLookupWithTTL
}
domains
= do
Expand All @@ -377,47 +386,43 @@ resolveDomainAccessPoint tracer
Right resolver -> do
let lookups =
[ (,) domain
<$> dnsLookupAWithTTL
<$> dnsLookupWithTTL
resolvConf
resolver
(dapDomain domain)
| domain <- domains ]
-- The timeouts here are handled by the 'lookupAWithTTL'. They're
-- 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)
sequence_
[ traceWith tracer $ case result of
Left dnserr -> TracePublicRootFailure dapDomain dnserr
Right ipttls -> TracePublicRootResult dapDomain ipttls
| (DomainAccessPoint {dapDomain}, result) <- results ]
return $ foldl' buildResult Map.empty results

buildResult :: Map DomainAccessPoint (Set Socket.SockAddr)
-> (DomainAccessPoint, Either DNS.DNSError [(IPv4, DNS.TTL)])
-> Map DomainAccessPoint (Set Socket.SockAddr)
buildResult mr (_, Left _) = mr
buildResult mr (domain, Right ipsttls) =
Map.alter addFn domain mr
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 ( Socket.SockAddrInet (dapPortNumber domain)
. IP.toHostAddress)
ips
!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 ( Socket.SockAddrInet (dapPortNumber domain)
. IP.toHostAddress)
ips
!addrs = map (\ip -> IP.toSockAddr (ip, dapPortNumber domain))
ips
!addrSet' = Set.union addrSet (Set.fromList addrs) in
Just addrSet'


---------------------------------------------
-- Shared utils
--
Expand Down
Loading

0 comments on commit a75771f

Please sign in to comment.