Refactor PeerSelection.RootPeersDNS

- Refactor `withLedgerPeers` & `resolveDomainAccessPoint`
  - Removes `withLedgerPeers` (only used in tests now)
  - `withPeerSelectionActions` is responsible for fetching and resolving
    all peers
  - Renames `resolveDomainAccessPoint` to `resolveLedgerPeers`
- Splits `Ouroboros.Network.PeerSelection.RootPeersDNS` into
  - `Ouroboros.Network.PeerSelection.DNS.RootPeers`
  - `Ouroboros.Network.PeerSelection.DNS.LocalRoots`
  - `Ouroboros.Network.PeerSelection.DNS.LedgerPeers`
  - `Ouroboros.Network.PeerSelection.DNS.DNSSemaphore`

ouroboros-network/CHANGELOG.md

@@ -4,6 +4,11 @@
 
 ### Breaking changes
 
+* Refactors `PeerSelection.RootPeersDNS` module, enabling more sharing between
+  modules and providing just better module organisation overall.
+    * Tweaks exports and imports
+    * Shares semaphores with `withPeerSelectionActions` and `ledgerPeersThread`
+
 ### Non-breaking changes
 
 * Less aggresive churning of established and known peers.

ouroboros-network/ouroboros-network.cabal

@@ -46,12 +46,14 @@ library
                        Ouroboros.Network.NodeToClient
                        Ouroboros.Network.Tracers
                        Ouroboros.Network.PeerSelection.Types
-                       Ouroboros.Network.PeerSelection.LedgerPeers
                        Ouroboros.Network.PeerSelection.PeerMetric
                        Ouroboros.Network.PeerSelection.PeerSelectionActions
                        Ouroboros.Network.PeerSelection.PeerStateActions
                        Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
-                       Ouroboros.Network.PeerSelection.RootPeersDNS
+                       Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore
+                       Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers
+                       Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
+                       Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers
                        Ouroboros.Network.PeerSelection.Governor
                        Ouroboros.Network.PeerSelection.State.EstablishedPeers
                        Ouroboros.Network.PeerSelection.State.KnownPeers

ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
@@ -22,11 +21,8 @@ module Test.Ouroboros.Network.Diffusion.Node
     -- * extra types used by the node
   , AcceptedConnectionsLimit (..)
   , DiffusionMode (..)
-  , LedgerPeersConsensusInterface (..)
   , PeerAdvertise (..)
   , PeerSelectionTargets (..)
-  , RelayAccessPoint (..)
-  , UseLedgerAfter (..)
     -- * configuration constants
   , config_RECONNECT_DELAY
   ) where
@@ -79,13 +75,8 @@ import           Ouroboros.Network.ExitPolicy (ReconnectDelay (..))
 import           Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
 import           Ouroboros.Network.PeerSelection.Governor
                      (PeerSelectionTargets (..))
-import           Ouroboros.Network.PeerSelection.LedgerPeers
-                     (LedgerPeersConsensusInterface (..), UseLedgerAfter (..))
 import           Ouroboros.Network.PeerSelection.PeerMetric
                      (PeerMetricsConfiguration (..), newPeerMetric)
-import           Ouroboros.Network.PeerSelection.RootPeersDNS
-                     (DomainAccessPoint (..), LookupReqs (..),
-                     RelayAccessPoint (..), newLocalAndPublicRootDNSSemaphore)
 import           Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..))
 import           Ouroboros.Network.Protocol.Handshake.Codec
                      (VersionDataCodec (..), noTimeLimitsHandshake,
@@ -108,6 +99,12 @@ import           Simulation.Network.Snocket (AddressType (..), FD)
 import           Ouroboros.Network.PeerSelection.PeerAdvertise
                      (PeerAdvertise (..))
 import           Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
+import           Ouroboros.Network.PeerSelection.RelayAccessPoint
+                     (DomainAccessPoint, RelayAccessPoint)
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
+                     (LedgerPeersConsensusInterface, UseLedgerAfter)
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
+                     (DNSLookupType)
 import           Ouroboros.Network.PeerSelection.State.LocalRootPeers
                      (HotValency, WarmValency)
 import           Ouroboros.Network.PeerSharing
@@ -127,7 +124,7 @@ data Interfaces m = Interfaces
     { iNtnSnocket        :: Snocket m (NtNFD m) NtNAddr
     , iNtnBearer         :: MakeBearer m (NtNFD m)
     , iAcceptVersion     :: NtNVersionData -> NtNVersionData -> Accept NtNVersionData
-    , iNtnDomainResolver :: LookupReqs -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr))
+    , iNtnDomainResolver :: DNSLookupType -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr))
     , iNtcSnocket        :: Snocket m (NtCFD m) NtCAddr
     , iNtcBearer         :: MakeBearer m (NtCFD m)
     , iRng               :: StdGen
@@ -203,7 +200,6 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch =
       $ \ nodeKernel nodeKernelThread -> do
         dnsTimeoutScriptVar <- LazySTM.newTVarIO (aDNSTimeoutScript na)
         dnsLookupDelayScriptVar <- LazySTM.newTVarIO (aDNSLookupDelayScript na)
-        dnsSemaphore <- newLocalAndPublicRootDNSSemaphore
         peerMetrics <- newPeerMetric PeerMetricsConfiguration { maxEntriesToTrack = 180 }
 
         peerSharingRegistry <- PeerSharingRegistry <$> newTVarIO mempty
@@ -235,7 +231,6 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch =
                     InitiatorAndResponderDiffusionMode -> Duplex
               , Diff.P2P.diNtnPeerSharing        = ntnPeerSharing
               , Diff.P2P.diNtnToPeerAddr         = \a b -> TestAddress (Node.IPAddr a b)
-              , Diff.P2P.diNtnDomainResolver     = iNtnDomainResolver ni
               , Diff.P2P.diNtcSnocket            = iNtcSnocket ni
               , Diff.P2P.diNtcBearer             = iNtcBearer ni
               , Diff.P2P.diNtcHandshakeArguments =
@@ -254,7 +249,6 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch =
                                                      (iDomainMap ni)
                                                      dnsTimeoutScriptVar
                                                      dnsLookupDelayScriptVar)
-              , Diff.P2P.diLocalAndPublicRootDnsSemaphore = dnsSemaphore
               }
 
             appsExtra :: Diff.P2P.ApplicationsExtra NtNAddr m ()

ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs

@@ -77,8 +77,6 @@ import qualified Ouroboros.Network.Mock.Chain as Chain
 import           Ouroboros.Network.Mock.ProducerState
 import           Ouroboros.Network.Mux
 import           Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
-import           Ouroboros.Network.PeerSelection.LedgerPeers
-                     (LedgerPeersConsensusInterface)
 import           Ouroboros.Network.Util.ShowProxy
 
 import           Ouroboros.Network.Mock.ConcreteBlock
@@ -91,6 +89,8 @@ import           Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum,
                      chainSyncMiniProtocolNum, keepAliveMiniProtocolNum,
                      peerSharingMiniProtocolNum)
 import qualified Ouroboros.Network.PeerSelection.PeerSharing as PSTypes
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
+                     (LedgerPeersConsensusInterface)
 import           Ouroboros.Network.PeerSharing (bracketPeerSharingClient,
                      peerSharingClient, peerSharingServer)
 import           Ouroboros.Network.Protocol.PeerSharing.Client

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

@@ -1,8 +1,10 @@
-{-# LANGUAGE BangPatterns      #-}
-{-# LANGUAGE DerivingVia       #-}
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE DerivingVia         #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 
 module Test.Ouroboros.Network.LedgerPeers where
 
@@ -21,7 +23,6 @@ import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (fromMaybe)
 import           Data.Monoid (Sum (..))
 import           Data.Ord (Down (..))
 import           Data.Ratio
@@ -31,9 +32,25 @@ import           Data.Word
 import           System.Random
 
 import           Network.DNS (Domain)
-import           Network.Socket (SockAddr)
-import           Ouroboros.Network.PeerSelection.LedgerPeers
-
+import           Network.Socket (PortNumber)
+
+import           Control.Concurrent.Class.MonadSTM.Strict
+import           Data.IP (IP)
+import           Ouroboros.Network.PeerSelection.LedgerPeers.Type
+                     (AccPoolStake (..), PoolStake (..))
+import           Ouroboros.Network.PeerSelection.RelayAccessPoint
+                     (RelayAccessPoint (..))
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
+                     (LedgerPeersConsensusInterface (..), LedgerPeersKind (..),
+                     NumberOfPeers (..), UseLedgerAfter (..),
+                     accBigPoolStake, accPoolStake, bigLedgerPeerQuota,
+                     withLedgerPeers)
+import           Ouroboros.Network.Testing.Data.Script (Script (..),
+                     initScript', stepScript')
+import           Test.Ouroboros.Network.PeerSelection.RootPeersDNS
+                     (DNSLookupDelay, DNSTimeout (..),
+                     DelayAndTimeoutScripts (..), MockRoots (..),
+                     mockDNSActions)
 import           Test.QuickCheck
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.QuickCheck (testProperty)
@@ -116,8 +133,11 @@ instance Arbitrary ArbLedgerPeersKind where
 prop_pick100 :: Word16
              -> NonNegative Int -- ^ number of pools with 0 stake
              -> ArbLedgerPeersKind
+             -> MockRoots
+             -> DelayAndTimeoutScripts
              -> Property
-prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) =
+prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoots _ dnsMapScript _ _)
+             (DelayAndTimeoutScripts dnsLookupDelayScript dnsTimeoutScript) =
     let rng = mkStdGen $ fromIntegral seed
         sps = [ (0, RelayAccessAddress (read $ "0.0.0." ++ show a) 1 :| [])
               | a <- [0..n]
@@ -129,11 +149,19 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) =
           BigLedgerPeers -> accBigPoolStake sps
 
         sim :: IOSim s [RelayAccessPoint]
-        sim = withLedgerPeers
+        sim = do
+          dnsMapScriptVar <- initScript' dnsMapScript
+          dnsMap <- stepScript' dnsMapScriptVar
+          dnsMapVar <- newTVarIO dnsMap
+
+          dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
+          dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
+
+          withLedgerPeers
                 rng (curry IP.toSockAddr) verboseTracer
                 (pure (UseLedgerAfter 0))
                 interface
-                (\_ -> pure Map.empty) -- we're not relying on domain name resolution in this simulation
+                (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar)
                 (\request _ -> do
                   threadDelay 1900 -- we need to invalidate ledger peer's cache
                   resp <- request (NumberOfPeers 1) ledgerPeersKind
@@ -165,15 +193,26 @@ prop_pick :: LedgerPools
           -> ArbLedgerPeersKind
           -> Word16
           -> Word16
+          -> MockRoots
+          -> Script DNSLookupDelay
           -> Property
-prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed =
+prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed (MockRoots _ dnsMapScript _ _)
+          dnsLookupDelayScript =
     let rng = mkStdGen $ fromIntegral seed
 
         sim :: IOSim s [RelayAccessPoint]
-        sim = withLedgerPeers
+        sim = do
+          dnsMapScriptVar <- initScript' dnsMapScript
+          dnsMap <- stepScript' dnsMapScriptVar
+          dnsMapVar <- newTVarIO dnsMap
+
+          dnsTimeoutScriptVar <- initScript' (Script (DNSTimeout 0 :| []))
+          dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
+          withLedgerPeers
                 rng (curry IP.toSockAddr) verboseTracer
                 (pure (UseLedgerAfter 0))
-                interface resolve
+                interface
+                (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar)
                 (\request _ -> do
                   threadDelay 1900 -- we need to invalidate ledger peer's cache
                   resp <- request (NumberOfPeers count) ledgerPeersKind
@@ -190,17 +229,6 @@ prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed =
             domainMap :: Map Domain (Set IP)
             domainMap = Map.fromList [("relay.iohk.example", Set.singleton (read "2.2.2.2"))]
 
-            resolve :: [DomainAccessPoint]
-                    -> IOSim s (Map DomainAccessPoint (Set SockAddr))
-            resolve = \daps ->
-              pure $ Map.fromList
-                     [ (dap, addrs)
-                     | dap@(DomainAccessPoint domain port) <- daps
-                     , let addrs = Set.map (\ip -> IP.toSockAddr (ip, port))
-                                 . fromMaybe Set.empty
-                                 $ Map.lookup domain domainMap
-                     ]
-
             reverseLookup :: RelayAccessPoint -> RelayAccessPoint
             reverseLookup ap@(RelayAccessAddress ip port)
               = case [ domain
@@ -262,12 +290,6 @@ prop_accBigPoolStake  (LedgerPools lps@(_:_)) =
   where
     accumulatedStakeMap = accBigPoolStake lps
 
-prop :: Property
-prop = prop_pick (LedgerPools [( PoolStake {unPoolStake = 1 % 1}
-                               , RelayAccessAddress (read "1.1.1.1") 1016 :| []
-                               )])
-                 (ArbLedgerPeersKind BigLedgerPeers) 0 2
-
 -- TODO: Belongs in iosim.
 data SimResult a = SimReturn a [String]
                  | SimException SomeException [String]

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

@@ -52,7 +52,6 @@ import           Network.Socket (SockAddr)
 import           Ouroboros.Network.PeerSelection.Governor hiding
                      (PeerSelectionState (..), peerSharing)
 import qualified Ouroboros.Network.PeerSelection.Governor as Governor
-import           Ouroboros.Network.PeerSelection.RootPeersDNS
 import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers
 import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers
 import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers
@@ -71,10 +70,19 @@ import           Test.Ouroboros.Network.PeerSelection.PeerGraph
 import           Control.Concurrent.Class.MonadSTM.Strict (newTVarIO)
 import           Control.Monad.Class.MonadTime.SI
 import           Control.Monad.IOSim
-import           Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..))
 import           Ouroboros.Network.PeerSelection.PeerAdvertise
                      (PeerAdvertise (..))
 import           Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
+import           Ouroboros.Network.PeerSelection.RelayAccessPoint
+                     (RelayAccessPoint)
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore
+                     (newLedgerAndPublicRootDNSSemaphore)
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
+                     (IsLedgerPeer (..))
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers
+                     (publicRootPeersProvider)
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
+                     (DNSLookupType (..), ioDNSActions)
 import           Ouroboros.Network.PeerSelection.State.LocalRootPeers
                      (HotValency (..), LocalRootPeers, WarmValency (..))
 import           Ouroboros.Network.Protocol.PeerSharing.Type
@@ -2855,7 +2863,7 @@ _governorFindingPublicRoots :: Int
                             -> PeerSharing
                             -> IO Void
 _governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = do
-    dnsSemaphore <- newLocalAndPublicRootDNSSemaphore
+    dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
     publicRootPeersProvider
       tracer
       (curry IP.toSockAddr)

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

@@ -18,14 +18,15 @@ import           Data.Text.Encoding (encodeUtf8)
 import           Data.Word (Word32)
 
 import           Ouroboros.Network.PeerSelection.Governor
-import           Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..))
-import           Ouroboros.Network.PeerSelection.RootPeersDNS
-                     (DomainAccessPoint (..), RelayAccessPoint (..))
 
 import qualified Data.IP as IP
 import           Ouroboros.Network.PeerSelection.PeerAdvertise
                      (PeerAdvertise (..))
 import           Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
+import           Ouroboros.Network.PeerSelection.RelayAccessPoint
+                     (DomainAccessPoint (..), RelayAccessPoint (..))
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
+                     (IsLedgerPeer (..))
 import           Ouroboros.Network.Testing.Utils (prop_shrink_nonequal,
                      prop_shrink_valid)
 import           Test.QuickCheck

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

@@ -1,11 +1,11 @@
 module Test.Ouroboros.Network.PeerSelection.Json (tests) where
 
 import           Data.Aeson (decode, encode, fromJSON, toJSON)
-import           Ouroboros.Network.PeerSelection.RootPeersDNS
-                     (DomainAccessPoint (..), RelayAccessPoint (..))
 import           Test.Ouroboros.Network.PeerSelection.Instances ()
 
 import           Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise)
+import           Ouroboros.Network.PeerSelection.RelayAccessPoint
+                     (DomainAccessPoint, RelayAccessPoint)
 import           Test.QuickCheck
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.QuickCheck (testProperty)

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

@@ -1,10 +1,12 @@
 
 module Test.Ouroboros.Network.PeerSelection.KnownPeers (tests) where
 import           Data.Map (Map)
-import           Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer,
-                     RelayAccessPoint)
 import           Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise)
 import           Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing)
+import           Ouroboros.Network.PeerSelection.RelayAccessPoint
+                     (RelayAccessPoint)
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
+                     (IsLedgerPeer)
 import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers
 import           Test.Ouroboros.Network.PeerSelection.Instances ()
 import           Test.QuickCheck (Property, counterexample)

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

@@ -71,10 +71,12 @@ import           Test.Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRoo
 import           Test.Ouroboros.Network.PeerSelection.PeerGraph
 import           Test.Ouroboros.Network.ShrinkCarefully
 
-import           Ouroboros.Network.PeerSelection.LedgerPeers (IsBigLedgerPeer,
-                     IsLedgerPeer)
+import           Ouroboros.Network.PeerSelection.LedgerPeers.Type
+                     (IsBigLedgerPeer)
 import           Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise)
 import           Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
+                     (IsLedgerPeer)
 import           Ouroboros.Network.PeerSelection.Types (PeerStatus (..))
 import           Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount,
                      PeerSharingResult (..))