Added DNS Recoverability test

IntersectMBO · Apr 14, 2022 · ddf4317 · ddf4317
1 parent a81e8b8
commit ddf4317
Showing 1 changed file with 90 additions and 4 deletions.
diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Test.Ouroboros.Network.Testnet (tests) where
 
@@ -26,6 +27,8 @@ import           Data.Time (secondsToDiffTime)
 import           System.Random (mkStdGen)
 import           GHC.Exception.Type (SomeException)
 
+import qualified Network.DNS.Types as DNS
+
 import           Ouroboros.Network.Testing.Data.AbsBearerInfo
                      (AbsBearerInfo (..), attenuation, delay, toSduSize)
 import           Ouroboros.Network.PeerSelection.Governor
@@ -34,7 +37,7 @@ import           Ouroboros.Network.Testing.Data.Signal
                       (Events, Signal, eventsToList,
                       signalProperty)
 import           Ouroboros.Network.PeerSelection.RootPeersDNS
-                      (TraceLocalRootPeers, TracePublicRootPeers)
+                      (TraceLocalRootPeers (..), TracePublicRootPeers (..), dapDomain)
 import           Ouroboros.Network.PeerSelection.Types (PeerStatus(..))
 import           Ouroboros.Network.Driver.Limits (ProtocolTimeLimits(..))
 import           Ouroboros.Network.Diffusion.P2P
@@ -45,6 +48,8 @@ import qualified Ouroboros.Network.Testing.Data.Signal as Signal
 import qualified Ouroboros.Network.PeerSelection.Governor as Governor
 import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeers
 import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as EstablishedPeers
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
+                      (DNSorIOError(DNSError))
 import           Ouroboros.Network.Protocol.Handshake.Type
                       (ClientHasAgency(..), ServerHasAgency (..))
 import qualified Ouroboros.Network.Diffusion.P2P as Diff.P2P
@@ -90,6 +95,8 @@ tests =
                    prop_diffusionScript_commandScript_valid
     , testProperty "diffusion no livelock"
                    prop_diffusion_nolivelock
+    , testProperty "diffusion dns can recover from fails"
+                   prop_diffusion_dns_can_recover
     , testProperty "diffusion target established local"
                    prop_diffusion_target_established_local
     , testProperty "diffusion target active below"
@@ -268,9 +275,88 @@ prop_diffusion_nolivelock defaultBearerInfo diffScript@(DiffusionScript l) =
           | countdown threshold h = go t
           | otherwise = Just h
 
-        countdown 0 (_ : _) = False
-        countdown _ []      = True
-        countdown n (_ : es)  = countdown (n-1) es
+        countdown :: Int -> [(Time, e)] -> Bool
+        countdown 0 (_ : _)   = False
+        countdown _ []        = True
+        countdown !n (_ : es) = countdown (n-1) es
+
+-- | Test that verifies that that we can recover from DNS lookup failures.
+--
+-- This checks that if a node is configured with a local root peer through DNS,
+-- and then the peer gets disconnected, the DNS lookup fails (so you can’t
+-- reconnect). After a bit DNS lookup succeeds and you manage to connect again.
+--
+prop_diffusion_dns_can_recover :: AbsBearerInfo
+                                        -> DiffusionScript
+                                        -> Property
+prop_diffusion_dns_can_recover defaultBearerInfo diffScript =
+    let sim :: forall s . IOSim s Void
+        sim = diffusionSimulation (toBearerInfo defaultBearerInfo)
+                                  diffScript
+                                  tracersExtraWithTimeName
+                                  tracerDiffusionSimWithTimeName
+
+        events :: [Events DiffusionTestTrace]
+        events = fmap ( Signal.eventsFromList
+                      . fmap (\(WithName _ (WithTime t b)) -> (t, b))
+                      )
+               . Trace.toList
+               . splitWithNameTrace
+               . Trace.fromList ()
+               . fmap snd
+               . Signal.eventsToList
+               . Signal.eventsFromListUpToTime (Time (10 * 60 * 60))
+               . Trace.toList
+               . fmap (\(WithTime t (WithName name b)) -> (t, WithName name (WithTime t b)))
+               . withTimeNameTraceEvents
+                  @DiffusionTestTrace
+                  @NtNAddr
+               $ runSimTrace sim
+
+     in conjoin
+      $ verify_dns_can_recover
+      <$> events
+
+  where
+    verify :: Set DNS.Domain
+      -> Int
+      -> [Either (Set DNS.Domain) (Set DNS.Domain)]
+      -> Property
+    verify toRecover recovered []  =
+      counterexample (show toRecover ++ " none of these DNS names recovered")
+                     (Set.null toRecover || recovered > 0)
+    verify toRecover recovered (Left dns:t)  =
+      verify (toRecover <> dns) recovered t
+    verify toRecover recovered (Right dns:t) =
+      if all (`Set.member` toRecover) dns
+         then verify (Set.foldl' (flip Set.delete) toRecover dns)
+                     (recovered + 1)
+                     t
+         else verify toRecover recovered t
+
+    verify_dns_can_recover :: Events DiffusionTestTrace -> Property
+    verify_dns_can_recover events =
+          -- The left case is for DNS lookup failures
+          -- The right case is for DNS lookup successes
+      let psDNSLookups :: Events (Either (Set DNS.Domain) (Set DNS.Domain))
+          psDNSLookups =
+            Signal.selectEvents
+              (\case
+                DiffusionLocalRootPeerTrace (TraceLocalRootFailure dap (DNSError _)) ->
+                  Just (Left (Set.singleton (dapDomain dap)))
+                DiffusionPublicRootPeerTrace (TracePublicRootFailure bs _)           ->
+                  Just (Left (Set.singleton bs))
+                DiffusionLocalRootPeerTrace (TraceLocalRootResult dap _)  ->
+                  Just (Right (Set.singleton (dapDomain dap)))
+                DiffusionPublicRootPeerTrace (TracePublicRootResult bs _) ->
+                  Just (Right (Set.singleton bs))
+                _                                                                      ->
+                  Nothing
+              )
+            $ events
+
+       in counterexample (show psDNSLookups)
+        $ verify Set.empty 0 (map snd $ Signal.eventsToList psDNSLookups)
 
 -- | A variant of
 -- 'Test.Ouroboros.Network.PeerSelection.prop_governor_target_established_local'