Address review comments

IntersectMBO · Nov 8, 2023 · 6554654 · 6554654
1 parent a72e172
commit 6554654
Show file tree

Hide file tree

Showing 11 changed files with 107 additions and 117 deletions.
diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs
@@ -630,13 +630,20 @@ withConnectionManager ConnectionManagerArguments {
         waitForOutboundDemotion addr = do
           state <- readState
           case Map.lookup addr state of
-            Nothing                  -> return ()
-            Just UnknownConnectionSt -> return ()
-            Just InboundIdleSt {}    -> return ()
-            Just InboundSt {}        -> return ()
-            Just WaitRemoteIdleSt    -> return ()
-            Just TerminatedSt        -> return ()
-            Just _                   -> retry
+            Nothing                        -> return ()
+            Just UnknownConnectionSt       -> return ()
+            Just InboundIdleSt {}          -> return ()
+            Just InboundSt {}              -> return ()
+            Just WaitRemoteIdleSt          -> return ()
+            Just TerminatedSt              -> return ()
+            Just (UnnegotiatedSt Inbound)  -> return ()
+            Just (UnnegotiatedSt Outbound) -> retry
+            Just ReservedOutboundSt        -> retry
+            Just OutboundUniSt             -> retry
+            Just OutboundIdleSt {}         -> retry
+            Just OutboundDupSt {}          -> retry
+            Just DuplexSt                  -> retry
+            Just TerminatingSt             -> retry
 
         connectionManager :: ConnectionManager muxMode socket peerAddr
                                                handle handleError m

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs
@@ -19,7 +19,6 @@ import           Control.Monad.IOSim hiding (SimResult)
 import           Control.Tracer (Tracer (..), showTracing, traceWith)
 import qualified Data.IP as IP
 import           Data.List (foldl', intercalate, isPrefixOf, nub, sortOn)
-import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -32,27 +31,17 @@ import           Data.Word
 import           System.Random
 
 import           Network.DNS (Domain)
-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.DNSSemaphore
 import           Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
-                     (LedgerPeersConsensusInterface (..), LedgerPeersKind (..),
-                     NumberOfPeers (..), UseLedgerAfter (..), accBigPoolStake,
-                     accPoolStake, bigLedgerPeerQuota, withLedgerPeers)
-import           Ouroboros.Network.Testing.Data.Script (Script (..),
-                     initScript', stepScript')
+import           Ouroboros.Network.Testing.Data.Script
 import           Test.Ouroboros.Network.PeerSelection.RootPeersDNS
-                     (DNSLookupDelay, DNSTimeout (..),
-                     DelayAndTimeoutScripts (..), MockRoots (..),
-                     mockDNSActions)
 import           Test.QuickCheck
-import           Test.Tasty (TestTree, testGroup)
-import           Test.Tasty.QuickCheck (testProperty)
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
 import           Text.Printf
 
 tests :: TestTree
@@ -164,8 +153,10 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoot
           dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
           dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
 
+          dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
+
           withLedgerPeers
-                rng (curry IP.toSockAddr) verboseTracer
+                rng dnsSemaphore (curry IP.toSockAddr) verboseTracer
                 (pure (UseLedgerAfter 0))
                 interface
                 (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar)
@@ -215,8 +206,10 @@ prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed (Moc
 
           dnsTimeoutScriptVar <- initScript' (Script (DNSTimeout 0 :| []))
           dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
+          dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
+
           withLedgerPeers
-                rng (curry IP.toSockAddr) verboseTracer
+                rng dnsSemaphore (curry IP.toSockAddr) verboseTracer
                 (pure (UseLedgerAfter 0))
                 interface
                 (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar)

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs
@@ -71,26 +71,19 @@ import           Control.Concurrent.Class.MonadSTM.Strict (newTVarIO)
 import           Control.Monad.Class.MonadTime.SI
 import           Control.Monad.IOSim
 import           Ouroboros.Network.PeerSelection.PeerAdvertise
-                     (PeerAdvertise (..))
 import           Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
 import           Ouroboros.Network.PeerSelection.RelayAccessPoint
-                     (RelayAccessPoint)
 import           Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
-                     (DNSLookupType (..), ioDNSActions)
 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.State.LocalRootPeers
-                     (HotValency (..), LocalRootPeers, WarmValency (..))
 import           Ouroboros.Network.Protocol.PeerSharing.Type
                      (PeerSharingResult (..))
 import           Test.QuickCheck
-import           Test.Tasty (DependencyType (..), TestTree, after, testGroup)
-import           Test.Tasty.QuickCheck (testProperty)
-import           Text.Pretty.Simple (pPrint)
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+import           Text.Pretty.Simple
 
 -- Exactly as named.
 unfHydra :: Int
@@ -1444,8 +1437,8 @@ recentPeerShareActivity d =
     --TODO: we should be able to avoid primitiveTransformEvents and express
     -- this as some combo of keyed linger and keyed until.
   where
-    go :: Set PeerAddr
-       -> PSQ.OrdPSQ PeerAddr Time ()
+    go :: Set PeerAddr -- ^ Recently shared with peers
+       -> PSQ.OrdPSQ PeerAddr Time () -- ^ PSQ with next time to request to peers
        -> [E TestTraceEvent]
        -> [E (Maybe (Set PeerAddr), Set PeerAddr)]
     go !recentSet !recentPSQ txs@(E (TS t _) _ : _)
@@ -2735,12 +2728,12 @@ prop_governor_target_established_local env =
           (\local established recentFailures inProgressPromoteCold ->
               Set.unions
                 [ -- There are no opportunities if we're at or above target
-                  if Set.size groupEstablished >= warmTarget
+                  if Set.size groupEstablished >= warmTarget'
                      then Set.empty
                      else group Set.\\ established
                                 Set.\\ recentFailures
                                 Set.\\ inProgressPromoteCold
-                | (_, WarmValency warmTarget, group) <- LocalRootPeers.toGroupSets local
+                | (_, WarmValency warmTarget', group) <- LocalRootPeers.toGroupSets local
                 , let groupEstablished = group `Set.intersection` established
                 ]
           ) <$> govLocalRootPeersSig
@@ -2838,12 +2831,12 @@ prop_governor_target_active_local_below env =
           (\local established active recentFailures inProgressDemoteToCold ->
               Set.unions
                 [ -- There are no opportunities if we're at or above target
-                  if Set.size groupActive >= hotTarget
+                  if Set.size groupActive >= hotTarget'
                      then Set.empty
                      else groupEstablished Set.\\ active
                                            Set.\\ recentFailures
                                            Set.\\ inProgressDemoteToCold
-                | (HotValency hotTarget, _, group) <- LocalRootPeers.toGroupSets local
+                | (HotValency hotTarget', _, group) <- LocalRootPeers.toGroupSets local
                 , let groupActive      = group `Set.intersection` active
                       groupEstablished = group `Set.intersection` established
                 ]
@@ -2893,10 +2886,10 @@ prop_governor_target_active_local_above env =
           (\local active ->
               Set.unions
                 [ -- There are no opportunities if we're at or below target
-                  if Set.size groupActive <= hotTarget
+                  if Set.size groupActive <= hotTarget'
                      then Set.empty
                      else groupActive
-                | (HotValency hotTarget, _, group) <- LocalRootPeers.toGroupSets local
+                | (HotValency hotTarget', _, group) <- LocalRootPeers.toGroupSets local
                 , let groupActive = group `Set.intersection` active
                 ]
           ) <$> govLocalRootPeersSig

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs
@@ -4,9 +4,7 @@ import           Data.Map (Map)
 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)

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs
@@ -669,8 +669,7 @@ prop_diffusion_nofail defaultBearerInfo diffScript =
         -- lastTime = fst (last trace)
 
      -- run in `IO` so we can catch the pure 'AssertionFailed' exception
-     in -- classifySimulatedTime lastTime $
-        ioProperty $ do
+     in ioProperty $ do
        r <-
          evaluate ( foldl' (flip seq) True
                 $ [ assertPeerSelectionState st ()
@@ -2052,27 +2051,23 @@ prop_diffusion_async_demotions defaultBearerInfo diffScript =
                            Just $ Left (Just failures)
                          where
                            failures = Set.singleton peeraddr
-                       DiffusionPeerSelectionTrace (TraceDemoteWarmDone _ _ addr) ->
-                           Just $ Left failures
-                         where
-                           failures = Just $ Set.singleton addr
-                       DiffusionPeerSelectionTrace (TraceDemoteWarmBigLedgerPeerDone _ _ addr) ->
-                           Just $ Left failures
+                       DiffusionPeerSelectionTrace (TraceDemoteWarmFailed _ _ peeraddr _) ->
+                           Just $ Left (Just failures)
                          where
-                           failures = Just $ Set.singleton addr
-                       DiffusionPeerSelectionTrace (TraceDemoteHotDone _ _ addr) ->
-                           Just $ Left failures
+                           failures = Set.singleton peeraddr
+                       DiffusionPeerSelectionTrace (TracePromoteColdFailed _ _ peeraddr _ _) ->
+                           Just $ Left (Just failures)
                          where
-                           failures = Just $ Set.singleton addr
-                       DiffusionPeerSelectionTrace (TraceDemoteHotBigLedgerPeerDone _ _ addr) ->
-                           Just $ Left failures
+                           failures = Set.singleton peeraddr
+                       DiffusionPeerSelectionTrace (TracePromoteWarmFailed _ _ peeraddr _) ->
+                           Just $ Left (Just failures)
                          where
-                           failures = Just $ Set.singleton addr
-                       DiffusionPeerSelectionTrace (TraceDemoteWarmFailed _ _ peeraddr _) ->
+                           failures = Set.singleton peeraddr
+                       DiffusionPeerSelectionTrace (TraceDemoteWarmDone _ _ peeraddr) ->
                            Just $ Left (Just failures)
                          where
                            failures = Set.singleton peeraddr
-                       DiffusionPeerSelectionTrace (TracePromoteWarmFailed _ _ peeraddr _) ->
+                       DiffusionPeerSelectionTrace (TracePromoteColdBigLedgerPeerFailed _ _ peeraddr _ _) ->
                            Just $ Left (Just failures)
                          where
                            failures = Set.singleton peeraddr
@@ -2088,6 +2083,10 @@ prop_diffusion_async_demotions defaultBearerInfo diffScript =
                            Just $ Left (Just failures)
                          where
                            failures = Set.singleton peeraddr
+                       DiffusionPeerSelectionTrace (TraceDemoteWarmBigLedgerPeerDone _ _ peeraddr) ->
+                           Just $ Left (Just failures)
+                         where
+                           failures = Set.singleton peeraddr
                        DiffusionConnectionManagerTrace TrShutdown ->
                            Just $ Left Nothing
 

diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs
@@ -577,9 +577,9 @@ aboveTargetLocal actions
                                        Set.\\ inProgressDemoteHot
                                        Set.\\ inProgressDemoteToCold
                 numDemoteInProgress = Set.size inProgressDemoteHot
-                                    + Set.size (Set.intersection inProgressDemoteToCold
-                                                                 activePeers
-                                               )
+                                    + Set.size (inProgressDemoteToCold
+                                                `Set.intersection`
+                                                activePeers)
           , not (Set.null availableToDemote)
           , (HotValency hotTarget, members, membersActive) <- groupsAboveTarget
           , let membersAvailableToDemote = Set.intersection
@@ -647,6 +647,7 @@ aboveTargetOther actions
   , let numPeersToDemote = numActivePeers
                          - targetNumberOfActivePeers
                          - numDemoteInProgress
+                         - (Set.size inProgressDemoteToCold)
   , numPeersToDemote > 0
 
     -- Are there any hot peers we actually can pick to demote?

diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs
@@ -175,7 +175,6 @@ belowTargetOther actions
                    knownPeers,
                    establishedPeers,
                    inProgressPromoteCold,
-                   inProgressDemoteToCold,
                    targets = PeerSelectionTargets {
                                targetNumberOfEstablishedPeers
                              }
@@ -202,7 +201,6 @@ belowTargetOther actions
           availableToPromote = availableToConnect
                                  Set.\\ EstablishedPeers.toSet establishedPeers
                                  Set.\\ inProgressPromoteCold
-                                 Set.\\ inProgressDemoteToCold
           numPeersToPromote  = targetNumberOfEstablishedPeers
                              - numEstablishedPeers
                              - numConnectInProgress
@@ -255,7 +253,6 @@ belowTargetBigLedgerPeers actions
                             knownPeers,
                             establishedPeers,
                             inProgressPromoteCold,
-                            inProgressDemoteToCold,
                             targets = PeerSelectionTargets {
                                         targetNumberOfEstablishedBigLedgerPeers
                                       }
@@ -283,7 +280,6 @@ belowTargetBigLedgerPeers actions
           availableToPromote = availableToConnect
                                  Set.\\ EstablishedPeers.toSet establishedPeers
                                  Set.\\ inProgressPromoteCold
-                                 Set.\\ inProgressDemoteToCold
           numPeersToPromote  = targetNumberOfEstablishedBigLedgerPeers
                              - numEstablishedPeers
                              - numConnectInProgress

diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs
@@ -162,12 +162,14 @@ connections PeerSelectionActions{
           (rFuzz, fuzzRng'') = randomR (-2, 2 :: Double) fuzzRng'
           demotions' = (\a@(peerState, reconnectDelay) -> case peerState of
                          PeerHot  -> a
-                         PeerWarm -> ( peerState
-                                     , (\x -> (x + realToFrac aFuzz) `max` 0) <$> reconnectDelay
-                                     )
-                         PeerCooling -> ( peerState
-                                     , (\x -> (x + realToFrac rFuzz) `max` 0) <$> reconnectDelay
-                                     )
+                         PeerWarm ->
+                           ( peerState
+                           , (\x -> (x + realToFrac aFuzz) `max` 0) <$> reconnectDelay
+                           )
+                         PeerCooling ->
+                           ( peerState
+                           , (\x -> (x + realToFrac rFuzz) `max` 0) <$> reconnectDelay
+                           )
                          PeerCold -> a
                        ) <$> demotions
       return $ \now ->
@@ -368,12 +370,10 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers
           selectedToDemote  :: Set peeraddr
           selectedToDemote' :: Map peeraddr peerconn
 
-          selectedToDemote  = (activePeers `Set.intersection` removedSet)
+          selectedToDemote  = activePeers `Set.intersection` removedSet
                                 Set.\\ inProgressDemoteToCold
           selectedToDemote' = EstablishedPeers.toMap establishedPeers
-                               `Map.restrictKeys` (selectedToDemote
-                                                     Set.\\ inProgressDemoteHot
-                                                  )
+                               `Map.restrictKeys` selectedToDemote
       return $ \_now ->
 
           assert (Set.isSubsetOf