Peer selection bugfix and testing updates

cardano-diffusion/changelog.d/20251013_152200_crocodile-dentist_test_false_positive.md

@@ -0,0 +1,16 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+<!--
+### Breaking
+-->
+
+### Non-Breaking
+
+- fixed false positive in `prop_diffusion_target_active_below` testnet test
+- improved approach in general to target-chasing tests in diffusion testnet
+  and PeerSelection mock environment tests.

ouroboros-network/changelog.d/20251004_134906_crocodile-dentist_test_false_positive.md

@@ -0,0 +1,25 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+### Breaking
+
+- `linger` function's arm callback now returns a `Maybe Bool`
+- `keyedLinger'`s arm callback now returns a `Maybe (Set b)`
+- `keyedLinger'`'s arm callback now returns a `Maybe (Set b, DiffTime))`
+- The above changes allow those functions to reset signal state on `Nothing`
+
+### Non-Breaking
+
+- Added latch function to `Signal`
+- bugfix missed promotion/demotion opportunities in:
+  - `ActivePeers.aboveTargetBigLedgerPeers`
+  - `ActivePeers.aboveTargetOther`
+  - `EstablishedPeers.aboveTargetOther`
+  - `EstablishedPeers.aboveTargetBigLedgerPeers`
+  - `EstablishedPeers.belowTargetLocal`
+  - `EstablishedPeers.belowTargetOther`
+  - `ActivePeers.belowTargetLocal`

ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs

@@ -259,11 +259,12 @@ belowTargetLocal actions@PeerSelectionActions {
                      Set.\\ inProgressPromoteWarm
                      Set.\\ inProgressDemoteWarm
                      Set.\\ inProgressDemoteToCold
-                numPromoteInProgress = Set.size inProgressPromoteWarm
           , not (Set.null availableToPromote)
           , (HotValency hotTarget, members, membersActive) <- groupsBelowTarget
           , let membersAvailableToPromote = Set.intersection
                                               members availableToPromote
+                numPromoteInProgress      = Set.size (Set.intersection
+                                                       inProgressPromoteWarm members)
                 numMembersToPromote       = hotTarget
                                           - Set.size membersActive
                                           - numPromoteInProgress
@@ -686,20 +687,25 @@ aboveTargetBigLedgerPeers actions@PeerSelectionActions {
                           }
     -- Are we above the general target for number of active peers?
   | numActiveBigLedgerPeers > targetNumberOfActiveBigLedgerPeers
-
-    -- Would we demote any if we could?
-  , let numPeersToDemote = numActiveBigLedgerPeers
+  , let activeBigLedger = activePeers
+                              `Set.intersection` bigLedgerPeersSet
+        -- Would we demote any if we could?
+        numPeersToDemote = numActiveBigLedgerPeers
                          - targetNumberOfActiveBigLedgerPeers
                          - numDemoteInProgressBigLedgerPeers
+                         -- don't drop too many and don't fail to take an opportunity
+                         -- if there are warm peers which are async demoted
+                         - Set.size (Set.intersection
+                                       inProgressDemoteToCold
+                                       activeBigLedger)
   , numPeersToDemote > 0
 
     -- Are there any hot peers we actually can pick to demote?
     -- For the moment we say we cannot demote local root peers.
     -- TODO: review this decision. If we want to be able to demote local root
     -- peers, e.g. for churn and improved selection, then we'll need an extra
     -- mechanism to avoid promotion/demotion loops for local peers.
-  , let availableToDemote = activePeers
-                              `Set.intersection` bigLedgerPeersSet
+  , let availableToDemote = activeBigLedger
                               Set.\\ inProgressDemoteHot
                               Set.\\ inProgressDemoteToCold
                               Set.\\ LocalRootPeers.keysSet localRootPeers
@@ -890,23 +896,26 @@ aboveTargetOther actions@PeerSelectionActions {
                  }
     -- Are we above the general target for number of active peers?
   | numActivePeers > targetNumberOfActivePeers
-
-    -- Would we demote any if we could?
-  , let numPeersToDemote = numActivePeers
+  , let activeNonBig = activePeers Set.\\ bigLedgerPeersSet
+        -- Would we demote any if we could?
+        numPeersToDemote = numActivePeers
                          - targetNumberOfActivePeers
                          - numDemoteInProgress
-                         - (Set.size inProgressDemoteToCold)
+                         -- don't drop too many and don't fail to take an opportunity
+                         -- if there are warm peers which are async demoted
+                         - Set.size (Set.intersection
+                                       inProgressDemoteToCold
+                                       activeNonBig)
   , numPeersToDemote > 0
 
     -- Are there any hot peers we actually can pick to demote?
     -- For the moment we say we cannot demote local root peers.
     -- TODO: review this decision. If we want to be able to demote local root
     -- peers, e.g. for churn and improved selection, then we'll need an extra
     -- mechanism to avoid promotion/demotion loops for local peers.
-  , let availableToDemote = activePeers
+  , let availableToDemote = activeNonBig
                               Set.\\ inProgressDemoteHot
                               Set.\\ LocalRootPeers.keysSet localRootPeers
-                              Set.\\ bigLedgerPeersSet
                               Set.\\ inProgressDemoteToCold
   , not (Set.null availableToDemote)
   = Guarded Nothing $ do

ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs

@@ -159,7 +159,8 @@ belowTargetLocal actions@PeerSelectionActions {
           , let membersAvailableToPromote = Set.intersection members availableToPromote
                 numMembersToPromote       = warmTarget
                                           - Set.size membersEstablished
-                                          - numLocalConnectInProgress
+                                          - Set.size (Set.intersection
+                                                        localConnectInProgress members)
           , not (Set.null membersAvailableToPromote)
           , numMembersToPromote > 0
           ]
@@ -216,7 +217,7 @@ belowTargetLocal actions@PeerSelectionActions {
         viewKnownLocalRootPeers              = (localRootPeersSet, _),
         viewEstablishedLocalRootPeers        = (localEstablishedPeers, _),
         viewAvailableToConnectLocalRootPeers = (localAvailableToConnect, _),
-        viewColdLocalRootPeersPromotions     = (localConnectInProgress, numLocalConnectInProgress)
+        viewColdLocalRootPeersPromotions     = (localConnectInProgress, _)
       } = peerSelectionStateToView extraPeersToSet extraStateToExtraCounters st
 
 
@@ -256,6 +257,7 @@ belowTargetOther actions@PeerSelectionActions {
                    policyPickColdPeersToPromote
                  }
                  st@PeerSelectionState {
+                   localRootPeers,
                    knownPeers,
                    establishedPeers,
                    inProgressPromoteCold,
@@ -285,6 +287,7 @@ belowTargetOther actions@PeerSelectionActions {
           availableToPromote = availableToConnect
                                  Set.\\ EstablishedPeers.toSet establishedPeers
                                  Set.\\ inProgressPromoteCold
+                                 Set.\\ LocalRootPeers.keysSet localRootPeers
           numPeersToPromote  = targetNumberOfEstablishedPeers
                              - numEstablishedPeers
                              - numConnectInProgress
@@ -507,6 +510,7 @@ jobPromoteColdPeer PeerSelectionActions {
             (fuzz, stdGen') = randomR (-2, 2 :: Double) stdGen
 
             -- exponential backoff: 5s, 10s, 20s, 40s, 80s, 160s.
+            -- Don't forget to change in diffusion tests if changed here
             delay :: DiffTime
             delay = realToFrac fuzz
                   + fromIntegral
@@ -698,20 +702,20 @@ aboveTargetOther actions@PeerSelectionActions {
     -- Or more precisely, how many established peers could we demote?
     -- We only want to pick established peers that are not active, since for
     -- active one we need to demote them first.
-  | let peerSelectionView = peerSelectionStateToView extraPeersToSet extraStateToExtraCounters st
-        PeerSelectionView {
+  | let peerSelectionView@PeerSelectionView {
             viewKnownBigLedgerPeers = (bigLedgerPeersSet, _),
-            viewEstablishedPeers    = (_, numEstablishedPeers),
+            viewEstablishedPeers    = (establishedPeersSet, numEstablishedPeers),
             viewActivePeers         = (_, numActivePeers)
           }
-          =
-          peerSelectionView
+          = peerSelectionStateToView extraPeersToSet extraStateToExtraCounters st
         PeerSelectionCountersHWC {
             numberOfWarmLocalRootPeers = numLocalWarmPeers
           }
           =
           snd <$> peerSelectionView
-
+        warmPeers =
+                 establishedPeersSet
+          Set.\\ Set.unions [activePeers, LocalRootPeers.keysSet localRootPeers, bigLedgerPeersSet]
         -- One constraint on how many to demote is the difference in the
         -- number we have now vs the target. The other constraint is that
         -- we pick established peers that are not also active. These
@@ -725,17 +729,15 @@ aboveTargetOther actions@PeerSelectionActions {
                                    - numActivePeers)
                             - Set.size (inProgressDemoteWarm  Set.\\ bigLedgerPeersSet)
                             - Set.size (inProgressPromoteWarm Set.\\ bigLedgerPeersSet)
+                            - Set.size (Set.intersection warmPeers inProgressDemoteToCold)
+  , numPeersToDemote > 0
 
-        availableToDemote :: Set peeraddr
-        availableToDemote = EstablishedPeers.toSet establishedPeers
-                              Set.\\ activePeers
-                              Set.\\ LocalRootPeers.keysSet localRootPeers
-                              Set.\\ bigLedgerPeersSet
+  , let availableToDemote :: Set peeraddr
+        availableToDemote = warmPeers
                               Set.\\ inProgressDemoteWarm
                               Set.\\ inProgressPromoteWarm
                               Set.\\ inProgressDemoteToCold
-  , numPeersToDemote > 0
-  , not (Set.null availableToDemote)
+  , assert (not . Set.null $ availableToDemote) not (Set.null availableToDemote)
   = Guarded Nothing $ do
       selectedToDemote <- pickPeers memberExtraPeers st
                             policyPickWarmPeersToDemote
@@ -814,6 +816,9 @@ aboveTargetBigLedgerPeers actions@PeerSelectionActions {
     -- We only want to pick established peers that are not active, since for
     -- active one we need to demote them first.
   | let bigLedgerPeersSet = PublicRootPeers.getBigLedgerPeers publicRootPeers
+        warmBigLedgerPeers = EstablishedPeers.toSet establishedPeers
+                             `Set.intersection` bigLedgerPeersSet
+                              Set.\\ activePeers
         PeerSelectionCounters {
             numberOfEstablishedBigLedgerPeers = numEstablishedBigLedgerPeers,
             numberOfActiveBigLedgerPeers      = numActiveBigLedgerPeers
@@ -825,25 +830,22 @@ aboveTargetBigLedgerPeers actions@PeerSelectionActions {
         -- pick active peer.  The `min` is taken so that `pickPeers` is given
         -- consistent number of peers with the set of peers available to demote,
         -- i.e. `availableToDemote`.
-        numBigLedgerPeersToDemote    = min ( numEstablishedBigLedgerPeers
-                                           - targetNumberOfEstablishedBigLedgerPeers)
-                                           ( numEstablishedBigLedgerPeers
-                                           - numActiveBigLedgerPeers)
-                                     - Set.size inProgressDemoteWarm
-                                     - Set.size inProgressPromoteWarm
+        numBigLedgerPeersToDemote    =
+            min (numEstablishedBigLedgerPeers - targetNumberOfEstablishedBigLedgerPeers)
+                (numEstablishedBigLedgerPeers - numActiveBigLedgerPeers)
+          - Set.size inProgressDemoteWarm
+          - Set.size inProgressPromoteWarm
+          - Set.size (Set.intersection warmBigLedgerPeers inProgressDemoteToCold)
 
         availableToDemote :: Set peeraddr
-        availableToDemote = EstablishedPeers.toSet establishedPeers
-                             `Set.intersection` bigLedgerPeersSet
-                              Set.\\ activePeers
+        availableToDemote = warmBigLedgerPeers
                               Set.\\ inProgressDemoteWarm
                               Set.\\ inProgressPromoteWarm
                               Set.\\ inProgressDemoteToCold
 
   , numBigLedgerPeersToDemote > 0
-  , not (Set.null availableToDemote)
+  , assert (not $ Set.null availableToDemote) not (Set.null availableToDemote)
   = Guarded Nothing $ do
-
       selectedToDemote <- pickPeers memberExtraPeers st
                             policyPickWarmPeersToDemote
                             availableToDemote

ouroboros-network/tests-lib/lib/Test/Ouroboros/Network/Data/Signal.hs

@@ -41,6 +41,7 @@ module Test.Ouroboros.Network.Data.Signal
   , scanl
   , always
   , eventually
+  , latch
     -- * Set-based temporal operations
   , keyedTimeout
   , keyedLinger
@@ -53,7 +54,7 @@ import Prelude hiding (scanl, until)
 import Data.Bool (bool)
 import Data.Foldable qualified as Deque (toList)
 import Data.List (groupBy)
-import Data.Maybe (maybeToList)
+import Data.Maybe (fromMaybe, maybeToList)
 import Data.OrdPSQ (OrdPSQ)
 import Data.OrdPSQ qualified as PSQ
 import Data.Set (Set)
@@ -262,12 +263,13 @@ nubBy eq (Signal x0 xs0) =
 -- signal is @True@.
 --
 linger :: DiffTime
-       -> (a -> Bool)
+       -> (a -> Maybe Bool)
+       -- ^ Nothing to stop tracking
        -> Signal a
        -> Signal Bool
 linger d arm =
     fmap (not . Set.null)
-  . keyedLinger d (bool Set.empty (Set.singleton ()) . arm)
+  . keyedLinger d (fmap (bool Set.empty (Set.singleton ())) . arm)
 
 
 -- | Make a timeout signal, based on observing an underlying signal.
@@ -303,6 +305,17 @@ until start stop =
                (bool Set.empty (Set.singleton ()) . stop)
                (const False)
 
+-- | The signal is scrutinised with a function and if it returns Nothing,
+-- then the previous Signal output is maintained, otherwise the new
+-- signal value is provided.
+--
+latch :: (a -> Maybe b)
+      -> b
+      -> Signal a
+      -> Signal b
+latch f = scanl f'
+  where
+    f' z' e = fromMaybe z' (f e)
 
 -- | Make a signal that keeps track of recent activity, based on observing an
 -- underlying signal.
@@ -311,10 +324,11 @@ until start stop =
 --
 keyedLinger :: forall a b. Ord b
             => DiffTime
-            -> (a -> Set b)  -- ^ The activity set signal
+            -> (a -> Maybe (Set b))
+            -- ^ The activity set signal, Nothing to stop
             -> Signal a
             -> Signal (Set b)
-keyedLinger d arm = keyedLinger' (fmap (\x -> (x, d)) arm)
+keyedLinger d arm = keyedLinger' (fmap (\x -> (x, d)) <$> arm)
 
 -- | Make a signal that keeps track of recent activity, based on observing an
 -- underlying signal.
@@ -336,7 +350,8 @@ keyedLinger d arm = keyedLinger' (fmap (\x -> (x, d)) arm)
 -- those. This allow us to correctly identify valid promotion opportunities.
 --
 keyedLinger' :: forall a b. Ord b
-            => (a -> (Set b, DiffTime))  -- ^ The activity set signal
+            => (a -> Maybe (Set b, DiffTime))
+            -- ^ The activity set signal, resets on Nothing
             -> Signal a
             -> Signal (Set b)
 keyedLinger' arm =
@@ -347,19 +362,20 @@ keyedLinger' arm =
   where
     go :: Set b
        -> OrdPSQ b Time ()
-       -> [E (Set b, DiffTime)]
+       -> [E (Maybe (Set b, DiffTime))]
        -> [E (Set b)]
     go !_ !_ [] = []
 
-    go !lingerSet !lingerPSQ (E ts@(TS t _) xs : txs)
+    go !_ !_ (E _ts Nothing : txs) = go Set.empty PSQ.empty txs
+    go !lingerSet !lingerPSQ (E ts@(TS t _) xs@Just{} : txs)
       | Just (y, t', _, lingerPSQ') <- PSQ.minView lingerPSQ
       , t' < t
       , (ys, lingerPSQ'') <- PSQ.atMostView t' lingerPSQ'
       , let armed = Set.fromList $ y : map (\(a, _, _) -> a) ys
             lingerSet' = Set.difference lingerSet armed
       = E (TS t' 0) lingerSet' : go lingerSet' lingerPSQ'' (E ts xs : txs)
 
-    go !lingerSet !lingerPSQ (E ts@(TS t _) x : txs) =
+    go !lingerSet !lingerPSQ (E ts@(TS t _) (Just x) : txs) =
       let lingerSet' = lingerSet <> fst x
           t'         = addTime (snd x) t
           lingerPSQ' = Set.foldl' (\s y -> PSQ.insert y t' () s) lingerPSQ (fst x)
@@ -552,5 +568,3 @@ mergeBy cmp = merge
 
 data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b
   deriving (Eq, Show)
-
-