Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
@crocodile-dentist
crocodile-dentist committed Jan 13, 2025
1 parent dae29ba commit 7bd7527
Show file tree
Hide file tree
Showing 10 changed files with 380 additions and 369 deletions.
50 changes: 25 additions & 25 deletions ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,15 +35,15 @@ 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)
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
Expand Down Expand Up @@ -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
Expand Down
187 changes: 93 additions & 94 deletions ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs
View file
Original file line number Diff line number Diff line change
@@ -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)

Expand All @@ -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 }
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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)
12 changes: 9 additions & 3 deletions ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..))
Expand Down Expand Up @@ -201,6 +201,8 @@ data TracersExtra ntnAddr ntnVersion ntnVersionData
, dtInboundGovernorTransitionTracer
:: Tracer m (RemoteTransitionTrace ntnAddr)

, dtDNSTracer :: Tracer m (DnsTrace ntnAddr)

--
-- NodeToClient tracers
--
Expand Down Expand Up @@ -245,6 +247,7 @@ nullTracers =
, dtLocalConnectionManagerTracer = nullTracer
, dtLocalServerTracer = nullTracer
, dtLocalInboundGovernorTracer = nullTracer
, dtDnsTracer = nullTracer
}

-- | P2P Arguments Extras
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -659,6 +664,7 @@ runM Interfaces
, dtLocalConnectionManagerTracer
, dtLocalServerTracer
, dtLocalInboundGovernorTracer
, dtDnsTracer
}
Arguments
{ daIPv4Address
Expand Down Expand Up @@ -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,
Expand Down
21 changes: 11 additions & 10 deletions ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,8 +13,8 @@
#endif

module Ouroboros.Network.PeerSelection.LedgerPeers
( DomainAccessPoint (..)
, IP.IP (..)
( --DomainAccessPoint (..)
IP.IP (..)
, LedgerPeers (..)
, getLedgerPeers
, RelayAccessPoint (..)
Expand Down Expand Up @@ -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
Expand Down
Loading

0 comments on commit 7bd7527

Please sign in to comment.