From 84642509ac761690c6a1a507cc32ad66f326ef6e Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Mon, 18 Apr 2022 17:47:46 +0100 Subject: [PATCH] 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. --- .../Test/Ouroboros/Network/Diffusion/Node.hs | 13 +- .../Network/PeerSelection/RootPeersDNS.hs | 60 ++++--- .../Network/Testnet/Simulation/Node.hs | 157 +++++++++++++----- 3 files changed, 159 insertions(+), 71 deletions(-) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs index 61c17489b47..154a2fb072f 100644 --- 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 index c62c2d1f825..1844a85e865 100644 --- 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,6 +320,9 @@ 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 @@ -327,20 +330,30 @@ mockLocalRootPeersProvider tracer (MockRoots localRootPeers dnsMapScript _ _) _ <- 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 diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs index 3bd037dbe1c..1d59065fb3a 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs @@ -3,6 +3,8 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Test.Ouroboros.Network.Testnet.Simulation.Node ( SimArgs(..) @@ -28,8 +30,9 @@ import Control.Monad.Class.MonadTimer (MonadTimer, threadDelay) import Control.Tracer (Tracer, traceWith, nullTracer) import qualified Data.ByteString.Lazy as BL +import Data.Foldable (traverse_) import Data.IP (IP (..), toIPv4, toIPv6) -import Data.List ((\\), nub) +import Data.List ((\\), nub, delete) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -38,7 +41,7 @@ import Data.Time.Clock (secondsToDiffTime) import Data.Void (Void) import System.Random (StdGen, mkStdGen) -import Network.DNS (Domain) +import Network.DNS (Domain, TTL) import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..), ProtocolTimeLimits (..)) @@ -73,7 +76,7 @@ import qualified Test.Ouroboros.Network.Diffusion.Node as Node import Test.Ouroboros.Network.Diffusion.Node.NodeKernel (BlockGeneratorArgs, NtNAddr, randomBlockGenerationArgs, NtNVersion, NtCVersion, NtCAddr, NtCVersionData, - NtNVersionData) + NtNVersionData, NtNAddr_ (IPAddr)) import qualified Test.Ouroboros.Network.Diffusion.Node.NodeKernel as Node import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay, DNSTimeout) @@ -117,7 +120,7 @@ data SimArgs = } deriving (Show) -data Command = JoinNetwork DiffTime +data Command = JoinNetwork DiffTime (Maybe NtNAddr) | Kill DiffTime | Reconfigure DiffTime [(Int, Map RelayAccessPoint PeerAdvertise)] @@ -135,16 +138,25 @@ genDomainMap raps = do return (Map.fromList m) - where - genIP :: [IP] -> Gen IP - genIP ips = - let genIPv4 = IPv4 . toIPv4 <$> replicateM 4 (choose (0,255)) - genIPv6 = IPv6 . toIPv6 <$> replicateM 8 (choose (0,0xffff)) - in oneof ([genIPv4, genIPv6] ++ map pure ips) +genIP :: [IP] -> Gen IP +genIP ips = + let genIPv4 = IPv4 . toIPv4 <$> replicateM 4 (choose (0,255)) + genIPv6 = IPv6 . toIPv6 <$> replicateM 8 (choose (0,0xffff)) + in oneof ([genIPv4, genIPv6] ++ map pure ips) genCommands :: [(Int, Map RelayAccessPoint PeerAdvertise)] -> Gen [Command] genCommands localRoots = sized $ \size -> do - commands <- vectorOf size (frequency [ (7, JoinNetwork <$> delay) + port <- fromIntegral <$> (arbitrary :: Gen Int) + commands <- vectorOf size (frequency [ (7, JoinNetwork + <$> delay + <*> ( Just + . TestAddress + . flip IPAddr port + <$> genIP [] + )) + , (7, JoinNetwork + <$> delay + <*> pure Nothing) , (4, Reconfigure <$> delay <*> subLocalRootPeers) @@ -164,17 +176,17 @@ genCommands localRoots = sized $ \size -> do fixupCommands :: [Command] -> [Command] fixupCommands [] = [] -fixupCommands (jn@(JoinNetwork _):t) = jn : go jn t +fixupCommands (jn@(JoinNetwork _ _):t) = jn : go jn t where go :: Command -> [Command] -> [Command] go _ [] = [] go prev (cmd:cmds) = case (prev, cmd) of - (JoinNetwork _, JoinNetwork _) -> go prev cmds - (Kill _, Kill _) -> go prev cmds - (Kill _, Reconfigure _ _) -> go prev cmds - (Reconfigure _ _, JoinNetwork _) -> go prev cmds - _ -> cmd : go cmd cmds + (JoinNetwork _ _ , JoinNetwork _ _ ) -> go prev cmds + (Kill _ , Kill _ ) -> go prev cmds + (Kill _ , Reconfigure _ _ ) -> go prev cmds + (Reconfigure _ _ , JoinNetwork _ _ ) -> go prev cmds + _ -> cmd : go cmd cmds fixupCommands (_:t) = fixupCommands t -- | Multinode Diffusion Simulator Script @@ -294,7 +306,8 @@ instance Arbitrary DiffusionScript where shrinkDelay = map fromRational . shrink . toRational shrinkCommand :: Command -> [Command] - shrinkCommand (JoinNetwork d) = JoinNetwork <$> shrinkDelay d + shrinkCommand (JoinNetwork d ip) = JoinNetwork <$> shrinkDelay d + <*> pure ip shrinkCommand (Kill d) = Kill <$> shrinkDelay d shrinkCommand (Reconfigure d lrp) = Reconfigure <$> shrinkDelay d <*> shrink lrp @@ -327,7 +340,7 @@ prop_diffusionScript_commandScript_valid (DiffusionScript ((_, cmds): t)) = isValid [_] = property True isValid (x:y:xs) = case (x, y) of - (JoinNetwork _, JoinNetwork _) -> + (JoinNetwork _ _, JoinNetwork _ _) -> counterexample ("Invalid sequence: " ++ show x ++ " " ++ show y) $ property False (Kill _, Kill _) -> @@ -336,7 +349,7 @@ prop_diffusionScript_commandScript_valid (DiffusionScript ((_, cmds): t)) = (Kill _, Reconfigure _ _) -> counterexample ("Invalid sequence: " ++ show x ++ " " ++ show y) $ property False - (Reconfigure _ _, JoinNetwork _) -> + (Reconfigure _ _, JoinNetwork _ _) -> counterexample ("Invalid sequence: " ++ show x ++ " " ++ show y) $ property False _ -> isValid (y:xs) @@ -385,9 +398,14 @@ diffusionSimulation withSnocket nullTracer defaultBearerInfo Map.empty $ \ntnSnocket _ -> withSnocket nullTracer defaultBearerInfo Map.empty - $ \ntcSnocket _ -> + $ \ntcSnocket _ -> do + let dnsMaps = map (\(sa, _) + -> (saAddr sa, fmap (, 0) <$> saDomainMap sa)) + args + dnsMapVarMap <- Map.fromList <$> mapM (mapM (newTVarIO @m)) dnsMaps withAsyncAll - (map (uncurry (runCommand Nothing ntnSnocket ntcSnocket)) args) + (map (uncurry (runCommand Nothing ntnSnocket ntcSnocket dnsMapVarMap)) + args) $ \nodes -> do (_, x) <- waitAny nodes return x @@ -402,49 +420,98 @@ diffusionSimulation -- ^ Node to node Snocket -> Snocket m (FD m NtCAddr) NtCAddr -- ^ Node to client Snocket + -> Map NtNAddr (StrictTVar m (Map Domain [(IP, TTL)])) + -- ^ Map of domain map TVars to be updated in case a node changes its IP -> SimArgs -- ^ Simulation arguments needed in order to run a single node -> [Command] -- ^ List of commands/actions to perform for a single node -> m Void - runCommand Nothing ntnSnocket ntcSnocket simArgs [] = do + runCommand Nothing ntnSnocket ntcSnocket dMapVarMap simArgs [] = do threadDelay 3600 traceWith (diffSimTracerWithTimName (saAddr simArgs)) TrRunning - runCommand Nothing ntnSnocket ntcSnocket simArgs [] - runCommand (Just (_, _)) ntnSnocket ntcSnocket simArgs [] = do + runCommand Nothing ntnSnocket ntcSnocket dMapVarMap simArgs [] + runCommand (Just (_, _)) ntnSnocket ntcSnocket dMapVarMap simArgs [] = do -- We shouldn't block this runCommand thread waiting -- on the async since this will lead to a Deadlock on -- IOSim, since this returns Void. threadDelay 3600 traceWith (diffSimTracerWithTimName (saAddr simArgs)) TrRunning - runCommand Nothing ntnSnocket ntcSnocket simArgs [] - runCommand Nothing ntnSnocket ntcSnocket simArgs (JoinNetwork delay:cs) = do + runCommand Nothing ntnSnocket ntcSnocket dMapVarMap simArgs [] + runCommand Nothing ntnSnocket ntcSnocket dMapVarMap simArgs + (JoinNetwork delay Nothing:cs) = do threadDelay delay traceWith (diffSimTracerWithTimName (saAddr simArgs)) TrJoiningNetwork lrpVar <- newTVarIO $ saLocalRootPeers simArgs - withAsync (runNode simArgs ntnSnocket ntcSnocket lrpVar) $ \nodeAsync -> - runCommand (Just (nodeAsync, lrpVar)) ntnSnocket ntcSnocket simArgs cs - runCommand _ _ _ _ (JoinNetwork _:_) = + let dnsMapVar = dMapVarMap Map.! saAddr simArgs + withAsync (runNode simArgs ntnSnocket ntcSnocket lrpVar dnsMapVar) $ \nodeAsync -> + runCommand (Just (nodeAsync, lrpVar)) ntnSnocket ntcSnocket dMapVarMap simArgs cs + runCommand Nothing ntnSnocket ntcSnocket dMapVarMap simArgs + (JoinNetwork delay (Just ip):cs) = do + threadDelay delay + let simArgs' = simArgs { saAddr = ip } + traceWith (diffSimTracerWithTimName ip) TrJoiningNetwork + lrpVar <- newTVarIO $ saLocalRootPeers simArgs' + + -- Updating DomainMap entry now that the node is having a new IP + let dnsMapVar = dMapVarMap Map.! saAddr simArgs + let dMapVarMap' = Map.delete (saAddr simArgs) dMapVarMap + dMapVarMap'' = Map.insert ip dnsMapVar dMapVarMap' + + withAsync (runNode simArgs' ntnSnocket ntcSnocket lrpVar dnsMapVar) + $ \nodeAsync -> + withAsync (updateDomainMap delay (saAddr simArgs) ip dMapVarMap'') + $ \_ -> + runCommand (Just (nodeAsync, lrpVar)) ntnSnocket ntcSnocket + dMapVarMap'' simArgs' cs + runCommand _ _ _ _ _ (JoinNetwork _ _:_) = error "runCommand: Impossible happened" - runCommand (Just (async, _)) ntnSnocket ntcSnocket simArgs + runCommand (Just (async, _)) ntnSnocket ntcSnocket dMapVarMap simArgs (Kill delay:cs) = do threadDelay delay traceWith (diffSimTracerWithTimName (saAddr simArgs)) TrKillingNode cancel async - runCommand Nothing ntnSnocket ntcSnocket simArgs cs - runCommand _ _ _ _ (Kill _:_) = do + runCommand Nothing ntnSnocket ntcSnocket dMapVarMap simArgs cs + runCommand _ _ _ _ _ (Kill _:_) = do error "runCommand: Impossible happened" - runCommand Nothing _ _ _ (Reconfigure _ _:_) = + runCommand Nothing _ _ _ _ (Reconfigure _ _:_) = error "runCommand: Impossible happened" - runCommand (Just (async, lrpVar)) ntnSnocket ntcSnocket simArgs + runCommand (Just (async, lrpVar)) ntnSnocket ntcSnocket dMapVarMap simArgs (Reconfigure delay newLrp:cs) = do threadDelay delay traceWith (diffSimTracerWithTimName (saAddr simArgs)) TrReconfigurionNode _ <- atomically $ writeTVar lrpVar newLrp - runCommand (Just (async, lrpVar)) ntnSnocket ntcSnocket simArgs cs + runCommand (Just (async, lrpVar)) ntnSnocket ntcSnocket dMapVarMap simArgs + cs + + updateDomainMap :: DiffTime + -> NtNAddr + -> NtNAddr + -> Map NtNAddr (StrictTVar m (Map Domain [(IP, TTL)])) + -> m () + updateDomainMap delay + (TestAddress (IPAddr oldIP _)) + (TestAddress (IPAddr newIP _)) + dMapVarMap = do + threadDelay delay + traverse_ (\dMapVar -> atomically $ do + dnsMap <- readTVar dMapVar + let dnsMap' = + Map.mapWithKey + (\_ l -> + case lookup oldIP l of + Nothing -> l + Just ttl -> (newIP, ttl):delete (oldIP, ttl) l + ) + dnsMap + writeTVar dMapVar dnsMap' + ) + dMapVarMap + updateDomainMap _ _ _ _ = return () runNode :: SimArgs -> Snocket m (FD m NtNAddr) NtNAddr -> Snocket m (FD m NtCAddr) NtCAddr -> StrictTVar m [(Int, Map RelayAccessPoint PeerAdvertise)] + -> StrictTVar m (Map Domain [(IP, TTL)]) -> m Void runNode SimArgs { saSlot = bgaSlotDuration @@ -453,7 +520,6 @@ diffusionSimulation , saMbTime = mustReplyTimeout , saRelays = raps , saRng = stdGen - , saDomainMap = dMap , saAddr = rap , saLocalSelectionTargets = peerSelectionTargets , saDNSTimeoutScript = dnsTimeout @@ -461,7 +527,8 @@ diffusionSimulation } ntnSnocket ntcSnocket - lrpVar = + lrpVar + dMapVar = let acceptedConnectionsLimit = AcceptedConnectionsLimit maxBound maxBound 0 diffusionMode = InitiatorAndResponderDiffusionMode @@ -517,11 +584,10 @@ diffusionSimulation Node.Interfaces { Node.iNtnSnocket = ntnSnocket , Node.iAcceptVersion = acceptVersion - , Node.iNtnDomainResolver = (return .) - <$> domainResolver raps dMap + , Node.iNtnDomainResolver = domainResolver raps dMapVar , Node.iNtcSnocket = ntcSnocket , Node.iRng = stdGen - , Node.iDomainMap = dMap + , Node.iDomainMap = dMapVar , Node.iLedgerPeersConsensusInterface = LedgerPeersConsensusInterface $ \_ -> return Nothing @@ -552,11 +618,12 @@ diffusionSimulation (tracersExtraWithTimeName rap) domainResolver :: [RelayAccessPoint] - -> Map Domain [IP] + -> StrictTVar m (Map Domain [(IP, TTL)]) -> LookupReqs -> [DomainAccessPoint] - -> Map DomainAccessPoint (Set NtNAddr) - domainResolver raps dMap _ daps = do + -> m (Map DomainAccessPoint (Set NtNAddr)) + domainResolver raps dMapVar _ daps = do + dMap <- fmap (map fst) <$> atomically (readTVar dMapVar) let domains = [ (d, p) | RelayAccessDomain d p <- raps ] domainsAP = uncurry DomainAccessPoint <$> domains mapDomains = [ ( DomainAccessPoint d p @@ -567,7 +634,7 @@ diffusionSimulation | DomainAccessPoint d p <- domainsAP \\ daps , Map.member d dMap ] - Map.fromList mapDomains + return (Map.fromList mapDomains) ntnToPeerAddr :: IP -> PortNumber -> NtNAddr