wip

wip

wip

ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs

@@ -35,15 +35,13 @@ 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.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 NoThunks.Class
 
 import Ouroboros.Network.PeerSelection.RelayAccessPoint
@@ -254,32 +252,21 @@ 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
 
 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 rap =
+          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 rap
     where
       fullyQualified = \case
         domain | Just (_, '.') <- BS.unsnoc domain -> domain

ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs

@@ -1,23 +1,16 @@
 {-# LANGUAGE BangPatterns      #-}
 {-# LANGUAGE BlockArguments    #-}
-{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms   #-}
 {-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE ViewPatterns      #-}
 
 module Ouroboros.Network.PeerSelection.RelayAccessPoint
-  ( DomainAccessPoint (..)
-  , DomainPlainAccessPoint (..)
-  , DomainSRVAccessPoint (..)
-  , RelayAccessPoint (.., RelayDomainAccessPoint)
+  ( RelayAccessPoint (..)
   , RelayAccessPointCoded (..)
   , IP.IP (..)
     -- * Socket type re-exports
   , Socket.PortNumber
   ) where
 
-import Control.Applicative ((<|>))
 import Control.DeepSeq (NFData (..))
 import Control.Monad (unless)
 
@@ -34,83 +27,12 @@ import Cardano.Binary qualified as Codec
 import Network.DNS qualified as DNS
 import Network.Socket qualified as Socket
 
--- | Types of domains supported
--- NB: A deliberately limited subset of SRV is supported.
--- Concretely, a peer from only the top priority level may
--- be given a chance to connect by the peer selection governor. Other
--- priority levels will not be considered. If there are multiple records
--- of the top priority (ie. lowest numerical value), a weighted random
--- sampling is in fact performed by this implementation, and addresses
--- 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
-      ]
-
 -- | 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 }
@@ -178,29 +100,6 @@ instance Show RelayAccessPoint where
     show (RelayAccessAddress ip port) =
       "RelayAccessAddress \"" ++ show ip ++ "\" " ++ show port
 
-
--- | '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
-
-{-# 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
-
-
 -- 'IP' nor 'IPv6' is strict, 'IPv4' is strict only because it's a newtype for
 -- a primitive type ('Word32').
 --
@@ -222,6 +121,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 +143,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)

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs

@@ -290,8 +290,8 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoot
 
           withLedgerPeers
                 PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr,
-                                 paDnsActions = mockDNSActions
-                                                   @SomeException
+                                 paDnsActions = mockDNSActions @SomeException
+                                                   (Tracer traceM)
                                                    LookupReqAOnly
                                                    dnsMapVar
                                                    dnsTimeoutScriptVar
@@ -356,8 +356,8 @@ prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed (Moc
 
           withLedgerPeers
                 PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr,
-                                 paDnsActions = mockDNSActions
-                                                  @SomeException
+                                 paDnsActions = mockDNSActions @SomeException
+                                                  (Tracer traceM)
                                                   LookupReqAOnly
                                                   dnsMapVar
                                                   dnsTimeoutScriptVar

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs

@@ -3791,7 +3791,7 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains readUseBootstrap
       dnsSemaphore
       DNS.defaultResolvConf
       readDomains
-      (ioDNSActions LookupReqAAndAAAA)
+      (ioDNSActions LookupReqAAndAAAA tracer)
       (mkStdGen 42) $ \requestPublicRootPeers -> do
         peerSelectionGovernor
           tracer tracer tracer

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Instances.hs

@@ -11,7 +11,6 @@ module Test.Ouroboros.Network.PeerSelection.Instances
     PeerAddr (..)
   , TestSeed (..)
     -- generators
-  , genDomainName
   , genIPv4
   , genIPv6
   , genPort
@@ -20,7 +19,6 @@ module Test.Ouroboros.Network.PeerSelection.Instances
   , prop_shrink_PeerSelectionTargets
   ) where
 
-import Data.ByteString (ByteString)
 import Data.ByteString.Char8 qualified as BSC
 import Data.Hashable
 import Data.IP qualified as IP
@@ -57,7 +55,7 @@ newtype TestSeed = TestSeed { unTestSeed :: Int }
 
 instance Arbitrary TestSeed where
   arbitrary = TestSeed <$> chooseInt(minBound, maxBound)
-  shrink seed = [seed]
+  shrink _ = []
 
 -- | Simple address representation for the tests
 --
@@ -158,17 +156,6 @@ instance Arbitrary ConsensusModePeerTargets where
        | deadlineTargets'' <- deadlineTargets',
          syncTargets'' <- syncTargets']
 
-instance Arbitrary DomainAccessPoint where
-  arbitrary = oneof [plain, srv]
-    where
-      plain = DomainAccessPoint <$> (DomainPlain
-              <$> genDomainName
-              <*> genPort)
-      srv = DomainSRVAccessPoint <$> (DomainSRV <$> genDomainName)
-
-genDomainName :: Gen ByteString
-genDomainName = elements $ (\i -> "test" <> (BSC.pack . show $ i)) <$> [1..6 :: Int]
-
 genIPv4 :: Gen IP.IP
 genIPv4 =
     IP.IPv4 . IP.toIPv4w <$> resize 200 arbitrary `suchThat` (> 100)
@@ -193,6 +180,8 @@ instance Arbitrary RelayAccessPoint where
       frequency [ (4, RelayAccessAddress <$> oneof [genIPv4, genIPv6] <*> genPort)
                 , (4, RelayAccessDomain <$> genDomainName <*> genPort)
                 , (1, RelayAccessSRVDomain <$> genDomainName)]
+    where
+      genDomainName = elements $ (\i -> "test" <> (BSC.pack . show $ i)) <$> [1..6 :: Int]
 
 prop_arbitrary_PeerSelectionTargets :: PeerSelectionTargets -> Bool
 prop_arbitrary_PeerSelectionTargets =

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Json.hs

@@ -4,8 +4,7 @@ import Data.Aeson (decode, encode, fromJSON, toJSON)
 import Test.Ouroboros.Network.PeerSelection.Instances ()
 
 import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise)
-import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint,
-           RelayAccessPoint)
+import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint)
 import Test.QuickCheck
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
@@ -14,18 +13,11 @@ tests :: TestTree
 tests =
   testGroup "Ouroboros.Network.PeerSelection"
   [ testGroup "JSON"
-    [ testProperty "DomainAccessPoint roundtrip" prop_roundtrip_DomainAccessPoint_JSON
-    , testProperty "RelayAccessPoint roundtrip"  prop_roundtrip_RelayAccessPoint_JSON
+    [ testProperty "RelayAccessPoint roundtrip"  prop_roundtrip_RelayAccessPoint_JSON
     , testProperty "PeerAdvertise roundtrip"     prop_roundtrip_PeerAdvertise_JSON
     ]
   ]
 
-prop_roundtrip_DomainAccessPoint_JSON :: DomainAccessPoint -> Property
-prop_roundtrip_DomainAccessPoint_JSON da =
-    decode (encode da) === Just da
-    .&&.
-    fromJSON (toJSON da) === pure da
-
 prop_roundtrip_RelayAccessPoint_JSON :: RelayAccessPoint -> Property
 prop_roundtrip_RelayAccessPoint_JSON ra =
     decode (encode ra) === Just ra
@@ -37,4 +29,3 @@ prop_roundtrip_PeerAdvertise_JSON pa =
     decode (encode pa) === Just pa
     .&&.
     fromJSON (toJSON pa) === pure pa
-