Makes iDomainMap mutable to accomodate DNS changes.

Refactor RootPeersDNS tests to use this change instead of a script of domain maps. Updates JoinNetwork command with possible IP change. If a node restarts with a new IP there's a new thread to update the Domain maps accordingly after some delay.
IntersectMBO · Apr 18, 2022 · 8464250 · 8464250
1 parent 868351b
commit 8464250
Show file tree

Hide file tree

Showing 3 changed files with 159 additions and 71 deletions.
diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs
@@ -35,7 +35,8 @@ import           Control.Monad.Class.MonadFork (MonadFork)
 import           Control.Monad.Class.MonadST (MonadST)
 import qualified Control.Monad.Class.MonadSTM as LazySTM
 import           Control.Monad.Class.MonadSTM.Strict (MonadLabelledSTM,
-                     MonadTraceSTM, MonadSTM (STM, atomically), newTVar)
+                     MonadTraceSTM, MonadSTM (STM, atomically), newTVar,
+                     StrictTVar)
 import           Control.Monad.Class.MonadThrow (MonadEvaluate, MonadMask,
                      MonadThrow, SomeException)
 import           Control.Monad.Class.MonadTime (DiffTime, MonadTime)
@@ -52,7 +53,7 @@ import           System.Random (StdGen, split)
 
 import qualified Codec.CBOR.Term as CBOR
 
-import           Network.DNS (Domain)
+import           Network.DNS (Domain, TTL)
 
 import           Ouroboros.Network.BlockFetch.Decision (FetchMode (..))
 import           Ouroboros.Network.ConnectionManager.Types (DataFlow (..))
@@ -84,7 +85,7 @@ import           Ouroboros.Network.Snocket (FileDescriptor (..), Snocket,
                      TestAddress (..))
 
 import           Ouroboros.Network.Testing.ConcreteBlock (Block)
-import           Ouroboros.Network.Testing.Data.Script (Script (..), singletonScript)
+import           Ouroboros.Network.Testing.Data.Script (Script (..))
 
 import           Simulation.Network.Snocket (AddressType (..), FD)
 
@@ -103,7 +104,7 @@ data Interfaces m = Interfaces
     , iNtnDomainResolver :: LookupReqs -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr))
     , iNtcSnocket        :: Snocket m (NtCFD m) NtCAddr
     , iRng               :: StdGen
-    , iDomainMap         :: Map Domain [IP]
+    , iDomainMap         :: StrictTVar m (Map Domain [(IP, TTL)])
     , iLedgerPeersConsensusInterface
                          :: LedgerPeersConsensusInterface m
     }
@@ -162,8 +163,6 @@ run :: forall resolver m.
 run blockGeneratorArgs limits ni na tracersExtra =
     Node.withNodeKernelThread blockGeneratorArgs
       $ \ nodeKernel nodeKernelThread -> do
-        dnsMapScriptVar <- LazySTM.newTVarIO
-                        $ singletonScript (fmap (, 0) <$> iDomainMap ni)
         dnsTimeoutScriptVar <- LazySTM.newTVarIO (aDNSTimeoutScript na)
         dnsLookupDelayScriptVar <- LazySTM.newTVarIO (aDNSLookupDelayScript na)
         peerMetrics  <- atomically $ PeerMetrics
@@ -204,7 +203,7 @@ run blockGeneratorArgs limits ni na tracersExtra =
               , Diff.P2P.diRng                   = diffStgGen
               , Diff.P2P.diInstallSigUSR1Handler = \_ -> pure ()
               , Diff.P2P.diDnsActions            = const (mockDNSActions
-                                                     dnsMapScriptVar
+                                                     (iDomainMap ni)
                                                      dnsTimeoutScriptVar
                                                      dnsLookupDelayScriptVar)
               }

diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs
@@ -18,7 +18,7 @@ module Test.Ouroboros.Network.PeerSelection.RootPeersDNS
 import           Ouroboros.Network.PeerSelection.RootPeersDNS
 import           Ouroboros.Network.PeerSelection.Types (PeerAdvertise (..))
 
-import           Control.Monad (replicateM_)
+import           Control.Monad (replicateM_, forever)
 import           Data.ByteString.Char8 (pack)
 import           Data.Dynamic (Typeable, fromDynamic)
 import           Data.Foldable (foldl', toList)
@@ -44,7 +44,7 @@ import           Control.Exception (throw)
 import           Control.Monad.Class.MonadAsync
 import qualified Control.Monad.Class.MonadSTM as LazySTM
 import           Control.Monad.Class.MonadSTM.Strict (MonadSTM, newTVarIO,
-                     readTVar, traceTVarIO, MonadTraceSTM, TraceValue(..))
+                     readTVar, traceTVarIO, MonadTraceSTM, TraceValue(..), StrictTVar, atomically, writeTVar)
 import           Control.Monad.Class.MonadThrow
 import           Control.Monad.Class.MonadTime (Time (..))
 import           Control.Monad.Class.MonadTimer
@@ -54,7 +54,7 @@ import           Control.Tracer (Tracer (Tracer), contramap)
 
 import           Ouroboros.Network.Testing.Data.Script (NonEmpty ((:|)),
                      Script (Script), initScript', stepScript, singletonScript,
-                     scriptHead)
+                     scriptHead, stepScript')
 import           Test.Ouroboros.Network.PeerSelection.Instances ()
 import           Test.QuickCheck
 import           Test.Tasty (TestTree, testGroup)
@@ -264,11 +264,11 @@ mockDNSActions :: forall exception m.
                   , MonadDelay m
                   , MonadTimer m
                   )
-               => LazySTM.TVar m (Script (Map Domain [(IP, TTL)]))
+               => StrictTVar m (Map Domain [(IP, TTL)])
                -> LazySTM.TVar m (Script DNSTimeout)
                -> LazySTM.TVar m (Script DNSLookupDelay)
                -> DNSActions () exception m
-mockDNSActions dnsMapScript dnsTimeoutScript dnsLookupDelayScript =
+mockDNSActions dnsMapVar dnsTimeoutScript dnsLookupDelayScript =
     DNSActions {
       dnsResolverResource,
       dnsAsyncResolverResource,
@@ -283,7 +283,7 @@ mockDNSActions dnsMapScript dnsTimeoutScript dnsLookupDelayScript =
                     -> Domain
                     -> m ([DNSError], [(IP, TTL)])
    dnsLookupWithTTL _ _ domain = do
-     dnsMap <- stepScript dnsMapScript
+     dnsMap <- atomically (readTVar dnsMapVar)
      DNSTimeout dnsTimeout <- stepScript dnsTimeoutScript
      DNSLookupDelay dnsLookupDelay <- stepScript dnsLookupDelayScript
 
@@ -320,27 +320,40 @@ mockLocalRootPeersProvider :: forall m.
 mockLocalRootPeersProvider tracer (MockRoots localRootPeers dnsMapScript _ _)
                            dnsTimeoutScript dnsLookupDelayScript = do
       dnsMapScriptVar <- initScript' dnsMapScript
+      dnsMap <- stepScript' dnsMapScriptVar
+      dnsMapVar <- newTVarIO dnsMap
+
       dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
       dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
       localRootPeersVar <- newTVarIO localRootPeers
       resultVar <- newTVarIO mempty
       _ <- traceTVarIO proxy
                        resultVar
                        (\_ a -> pure $ TraceDynamic (Solo a))
-
-      void $ MonadTimer.timeout 3600 $
-        localRootPeersProvider tracer
-                               (curry toSockAddr)
-                               DNSResolver.defaultResolvConf
-                               (mockDNSActions dnsMapScriptVar
-                                               dnsTimeoutScriptVar
-                                               dnsLookupDelayScriptVar)
-                               (readTVar localRootPeersVar)
-                               resultVar
+      withAsync (updateDNSMap dnsMapScriptVar dnsMapVar) $ \_ -> do
+        void $ MonadTimer.timeout 3600 $
+          localRootPeersProvider tracer
+                                 (curry toSockAddr)
+                                 DNSResolver.defaultResolvConf
+                                 (mockDNSActions dnsMapVar
+                                                 dnsTimeoutScriptVar
+                                                 dnsLookupDelayScriptVar)
+                                 (readTVar localRootPeersVar)
+                                 resultVar
   where
     proxy :: Proxy m
     proxy = Proxy
 
+    updateDNSMap :: LazySTM.TVar m (Script (Map Domain [(IP, TTL)]))
+                 -> StrictTVar m (Map Domain [(IP, TTL)])
+                 -> m Void
+    updateDNSMap dnsMapScriptVar dnsMapVar =
+      forever $ do
+        threadDelay 10
+        dnsMap <- stepScript' dnsMapScriptVar
+        atomically (writeTVar dnsMapVar dnsMap)
+
+
 -- | 'publicRootPeersProvider' running with a given MockRoots env.
 --
 -- NOTE: This function is used in 'prop_public_resolvesDomainsCorrectly'. Due to
@@ -362,16 +375,22 @@ mockPublicRootPeersProvider :: forall m a.
 mockPublicRootPeersProvider tracer (MockRoots _ _ publicRootPeers dnsMapScript)
                             dnsTimeoutScript dnsLookupDelayScript action = do
       dnsMapScriptVar <- initScript' dnsMapScript
+      dnsMap <- stepScript' dnsMapScriptVar
+      dnsMapVar <- newTVarIO dnsMap
+
       dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
       dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
       publicRootPeersVar <- newTVarIO publicRootPeers
-      replicateM_ 5 $
+      replicateM_ 5 $ do
+        dnsMap' <- stepScript' dnsMapScriptVar
+        atomically (writeTVar dnsMapVar dnsMap')
+
         publicRootPeersProvider tracer
                                 (curry toSockAddr)
                                 DNSResolver.defaultResolvConf
                                 (readTVar publicRootPeersVar)
                                 (mockDNSActions @Failure
-                                                dnsMapScriptVar
+                                                dnsMapVar
                                                 dnsTimeoutScriptVar
                                                 dnsLookupDelayScriptVar)
                                 action
@@ -390,11 +409,14 @@ mockResolveDomainAddresses :: ( MonadAsync m
 mockResolveDomainAddresses tracer (MockRoots _ _ publicRootPeers dnsMapScript)
                            dnsTimeoutScript dnsLookupDelayScript = do
       dnsMapScriptVar <- initScript' dnsMapScript
+      dnsMap <- stepScript' dnsMapScriptVar
+      dnsMapVar <- newTVarIO dnsMap
+
       dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
       dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
       resolveDomainAccessPoint tracer
                                DNSResolver.defaultResolvConf
-                               (mockDNSActions @Failure dnsMapScriptVar
+                               (mockDNSActions @Failure dnsMapVar
                                                         dnsTimeoutScriptVar
                                                         dnsLookupDelayScriptVar)
                                [ domain