Tests

IntersectMBO · Dec 10, 2024 · 34fd024 · 34fd024
1 parent f4e401f
commit 34fd024
Show file tree

Hide file tree

Showing 4 changed files with 284 additions and 201 deletions.
diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs
@@ -79,6 +79,7 @@ instance Arbitrary ArbitraryRelayAccessPoint where
       ArbitraryRelayAccessPoint <$>
         oneof [ RelayAccessAddress (read "1.1.1.1")     . getArbitraryPortNumber <$> arbitrary
               , RelayAccessDomain  "relay.iohk.example" . getArbitraryPortNumber <$> arbitrary
+              , pure $ RelayAccessSRVDomain  "_cardano._tcp.iohk.example"
               ]
 
 newtype ArbitraryLedgerStateJudgement =

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Instances.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Instances.hs
@@ -8,15 +8,19 @@
 
 module Test.Ouroboros.Network.PeerSelection.Instances
   ( -- test types
-    PeerAddr (..)
+    ArbitraryPlainDomain (..)
+  , PeerAddr (..)
     -- generators
   , genIPv4
   , genIPv6
+  , genPort
     -- generator tests
   , prop_arbitrary_PeerSelectionTargets
   , prop_shrink_PeerSelectionTargets
   ) where
 
+import Network.DNS qualified as DNS
+import Ouroboros.Network.PeerSelection.RelayAccessPoint
 import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word32, Word64)
 
@@ -26,6 +30,7 @@ import Ouroboros.Network.PeerSelection.Governor
 
 import Data.Hashable
 import Data.IP qualified as IP
+import Network.Socket
 import Ouroboros.Network.ConsensusMode
 import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
 import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..),
@@ -44,6 +49,8 @@ import Test.QuickCheck
 -- QuickCheck instances
 --
 
+newtype ArbitraryPlainDomain = ArbitraryPlainDomain DNS.Domain
+
 -- | Simple address representation for the tests
 --
 newtype PeerAddr = PeerAddr Int
@@ -143,13 +150,26 @@ instance Arbitrary ConsensusModePeerTargets where
        | deadlineTargets'' <- deadlineTargets',
          syncTargets'' <- syncTargets']
 
+-- | for sampling results from an SRV lookup
+--
+instance Arbitrary ArbitraryPlainDomain where
+  arbitrary = ArbitraryPlainDomain <$> elements domains
+    where
+      domains = encodeUtf8 <$> [ "fromsrv_1"
+                , "fromsrv_2"
+                , "fromsrv_3"
+                , "fromsrv_4"
+                , "fromsrv_5"
+                ]
+
 instance Arbitrary DomainAccessPoint where
-  arbitrary =
-    DomainAccessPoint . encodeUtf8
-      <$> elements domains
-      <*> (fromIntegral <$> (arbitrary :: Gen Int))
+  arbitrary = oneof [plain, srv]
     where
-      domains = [ "test1"
+      plain = DomainAccessPoint <$> (DomainPlain
+              <$> (("_srv" <>) <$> elements domains) -- ^ _srv just to tag sim trace
+              <*> genPort)
+      srv = DomainSRVAccessPoint <$> (DomainSRV <$> elements domains)
+      domains = encodeUtf8 <$> [ "test1"
                 , "test2"
                 , "test3"
                 , "test4"
@@ -160,6 +180,10 @@ genIPv4 :: Gen IP.IP
 genIPv4 =
     IP.IPv4 . IP.toIPv4w <$> arbitrary `suchThat` (> 100)
 
+genPort :: Gen PortNumber
+genPort =
+    fromIntegral <$> (arbitrary :: Gen Int)
+
 genIPv6 :: Gen IP.IP
 genIPv6 =
     IP.IPv6 . IP.toIPv6w <$> genFourWord32
@@ -173,11 +197,16 @@ genIPv6 =
 
 instance Arbitrary RelayAccessPoint where
   arbitrary =
-      oneof [ RelayDomainAccessPoint <$> arbitrary
-            , RelayAccessAddress <$> oneof [genIPv4, genIPv6]
-                                 <*> (fromIntegral
-                                     <$> (arbitrary :: Gen Int))
-            ]
+      frequency [ (4, RelayAccessAddress <$> oneof [genIPv4, genIPv6] <*> genPort)
+                , (4, RelayAccessDomain <$> elements domains <*> genPort)
+                , (1, RelayAccessSRVDomain <$> elements domains)]
+    where
+      domains = encodeUtf8 <$> [ "test1"
+                , "test2"
+                , "test3"
+                , "test4"
+                , "test5"
+                ]
 
 prop_arbitrary_PeerSelectionTargets :: PeerSelectionTargets -> Bool
 prop_arbitrary_PeerSelectionTargets =
@@ -187,4 +216,3 @@ prop_shrink_PeerSelectionTargets :: ShrinkCarefully PeerSelectionTargets -> Prop
 prop_shrink_PeerSelectionTargets x =
       prop_shrink_valid sanePeerSelectionTargets x
  .&&. prop_shrink_nonequal x
-
diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Json.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Json.hs
@@ -21,20 +21,19 @@ tests =
   ]
 
 prop_roundtrip_DomainAccessPoint_JSON :: DomainAccessPoint -> Property
-prop_roundtrip_DomainAccessPoint_JSON da =
-    decode (encode da) === Just da
-    .&&.
-    fromJSON (toJSON da) === pure da
+prop_roundtrip_DomainAccessPoint_JSON da = undefined
+    -- 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
-    .&&.
-    fromJSON (toJSON ra) === pure ra
+prop_roundtrip_RelayAccessPoint_JSON ra = undefined
+    -- decode (encode ra) === Just ra
+    -- .&&.
+    -- fromJSON (toJSON ra) === pure ra
 
 prop_roundtrip_PeerAdvertise_JSON :: PeerAdvertise -> Property
 prop_roundtrip_PeerAdvertise_JSON pa =
     decode (encode pa) === Just pa
     .&&.
     fromJSON (toJSON pa) === pure pa
-