peer-selection: introduced PeerSelectionView

PeerSelectionView is a generalisation of PeerSelectionCounters useful
internally in the outbound-governor.  It allows us to not duplicate the
logic of computing counters separately for churn and the outbound
governor, which can help us to introduce bugs.

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

@@ -81,7 +81,8 @@ import Ouroboros.Network.Testing.Data.Script
 import Ouroboros.Network.Testing.Data.Signal (E (E), Events, Signal, TS (TS),
            signalProperty)
 import Ouroboros.Network.Testing.Data.Signal qualified as Signal
-import Ouroboros.Network.Testing.Utils (nightlyTest)
+import Ouroboros.Network.Testing.Utils (disjointSetsProperty, isSubsetProperty,
+           nightlyTest)
 import Test.Ouroboros.Network.PeerSelection.Instances
 import Test.Ouroboros.Network.PeerSelection.MockEnvironment hiding (tests)
 import Test.Ouroboros.Network.PeerSelection.PeerGraph
@@ -101,7 +102,10 @@ unfHydra = 1
 tests :: TestTree
 tests =
   testGroup "Ouroboros.Network.PeerSelection"
-  [ testGroup "basic"
+  [ testGroup "PeerSelectionView"
+    [ testProperty "sizes" prop_peerSelectionView_sizes
+    ]
+  , testGroup "basic"
     [ testProperty "has output"         prop_governor_hasoutput
     , testProperty "no failure"         prop_governor_nofail
     , testProperty "no livelock"        prop_governor_nolivelock
@@ -211,6 +215,158 @@ tests =
 -- QuickCheck properties
 --
 
+prop_peerSelectionView_sizes :: GovernorMockEnvironment -> Property
+prop_peerSelectionView_sizes env =
+    let trace = runGovernorInMockEnvironment env
+        evs   = selectGovernorStateEvents
+              $ selectPeerSelectionTraceEventsUntil (Time (10 * 3600)) trace
+    in getAllProperty $
+       foldMap (\(_, TraceGovernorState _ _ st) ->
+                     AllProperty $
+                     let view = peerSelectionStateToView st in
+                          viewInvariant (fst <$> view)
+                     .&&. viewSizeInvariant view)
+               evs
+  where
+    viewInvariant :: PeerSelectionView (Set PeerAddr)
+                  -> Property
+    viewInvariant PeerSelectionView {..} =
+           isSubsetProperty "viewActivePeersDemotions" viewActivePeersDemotions viewActivePeers
+      .&&. isSubsetProperty "viewActivePeers" viewActivePeers viewEstablishedPeers
+      .&&. isSubsetProperty "viewEstablishedPeers" viewEstablishedPeers viewKnownPeers
+      .&&. isSubsetProperty "viewColdPeersPromotions" viewColdPeersPromotions viewKnownPeers
+      .&&. isSubsetProperty "viewAvailableToConnectPeers" viewAvailableToConnectPeers viewKnownPeers
+      .&&. isSubsetProperty "viewWarmPeersDemotions" viewWarmPeersDemotions (viewEstablishedPeers Set.\\ viewActivePeers)
+      .&&. isSubsetProperty "viewWarmPeersPromotions" viewWarmPeersPromotions (viewEstablishedPeers Set.\\ viewActivePeers)
+
+      .&&. isSubsetProperty "viewActiveBigLedgerPeersDemotions" viewActiveBigLedgerPeersDemotions viewActiveBigLedgerPeers
+      .&&. isSubsetProperty "viewActiveBigLedgerPeers" viewActiveBigLedgerPeers viewEstablishedBigLedgerPeers
+      .&&. isSubsetProperty "viewEstablishedBigLedgerPeers" viewEstablishedBigLedgerPeers viewKnownBigLedgerPeers
+      .&&. isSubsetProperty "viewColdBigLedgerPeersPromotions" viewColdBigLedgerPeersPromotions viewKnownBigLedgerPeers
+      .&&. isSubsetProperty "viewAvailableToConnectBigLedgerPeers" viewAvailableToConnectBigLedgerPeers viewKnownBigLedgerPeers
+      .&&. isSubsetProperty "viewWarmBigLedgerPeersDemotions" viewWarmBigLedgerPeersDemotions (viewEstablishedBigLedgerPeers Set.\\ viewActiveBigLedgerPeers)
+      .&&. isSubsetProperty "viewWarmBigLedgerPeersPromotions" viewWarmBigLedgerPeersPromotions (viewEstablishedBigLedgerPeers Set.\\ viewActiveBigLedgerPeers)
+
+      .&&. isSubsetProperty "viewActiveLocalRootPeersDemotions" viewActiveLocalRootPeersDemotions viewActiveLocalRootPeers
+      .&&. isSubsetProperty "viewActiveLocalRootPeers" viewActiveLocalRootPeers viewEstablishedLocalRootPeers
+      .&&. isSubsetProperty "viewEstablishedLocalRootPeers" viewEstablishedLocalRootPeers viewKnownLocalRootPeers
+      .&&. isSubsetProperty "viewColdLocalRootPeersPromotions" viewColdLocalRootPeersPromotions viewKnownLocalRootPeers
+      .&&. isSubsetProperty "viewAvailableToConnectLocalRootPeers" viewAvailableToConnectLocalRootPeers viewKnownLocalRootPeers
+      .&&. isSubsetProperty "viewWarmLocalRootPeersPromotions" viewWarmLocalRootPeersPromotions (viewEstablishedLocalRootPeers Set.\\ viewActiveLocalRootPeers)
+
+      .&&. isSubsetProperty "viewActiveSharedPeersDemotions" viewActiveSharedPeersDemotions viewActiveSharedPeers
+      .&&. isSubsetProperty "viewActiveSharedPeers" viewActiveSharedPeers viewEstablishedSharedPeers
+      .&&. isSubsetProperty "viewEstablishedSharedPeers" viewEstablishedSharedPeers viewKnownSharedPeers
+      .&&. isSubsetProperty "viewColdSharedPeersPromotions" viewColdSharedPeersPromotions viewKnownSharedPeers
+      .&&. isSubsetProperty "viewWarmSharedPeersPromotions" viewWarmSharedPeersPromotions (viewEstablishedSharedPeers Set.\\ viewActiveSharedPeers)
+      .&&. isSubsetProperty "viewWarmSharedPeersDemotions" viewWarmSharedPeersDemotions (viewEstablishedSharedPeers Set.\\ viewActiveSharedPeers)
+
+      .&&. isSubsetProperty "viewActiveBootstrapPeersDemotions" viewActiveBootstrapPeersDemotions viewActiveBootstrapPeers
+      .&&. isSubsetProperty "viewActiveBootstrapPeers" viewActiveBootstrapPeers viewEstablishedBootstrapPeers
+      .&&. isSubsetProperty "viewEstablishedBootstrapPeers" viewEstablishedBootstrapPeers viewKnownBootstrapPeers
+      .&&. isSubsetProperty "viewColdBootstrapPeersPromotions" viewColdBootstrapPeersPromotions viewKnownBootstrapPeers
+      .&&. isSubsetProperty "viewWarmBootstrapPeersPromotions" viewWarmBootstrapPeersPromotions (viewEstablishedBootstrapPeers Set.\\ viewActiveBootstrapPeers)
+      .&&. isSubsetProperty "viewWarmBootstrapPeersDemotions" viewWarmBootstrapPeersDemotions (viewEstablishedBootstrapPeers Set.\\ viewActiveBootstrapPeers)
+
+      .&&. disjointSetsProperty "viewKnownPeers viewKnownBigLedgerPeers" viewKnownPeers viewKnownBigLedgerPeers
+      .&&. isSubsetProperty "viewKnownLocalRootPeers" viewKnownLocalRootPeers viewKnownPeers
+      .&&. isSubsetProperty "viewKnownSharedPeers" viewKnownSharedPeers viewKnownPeers
+      .&&. isSubsetProperty "viewKnownBootstrapPeers" viewKnownBootstrapPeers viewKnownPeers
+
+      .&&. disjointSetsProperty "viewKnownLocalRootPeers-viewKnownBigLedgerPeers" viewKnownLocalRootPeers viewKnownBigLedgerPeers
+      .&&. disjointSetsProperty "viewKnownLocalRootPeers-viewKnownSharedPeers" viewKnownLocalRootPeers viewKnownSharedPeers
+      .&&. disjointSetsProperty "viewKnownLocalRootPeers-viewKnownBootstrapPeers" viewKnownLocalRootPeers viewKnownBootstrapPeers
+
+      .&&. disjointSetsProperty "viewKnownSharedPeers-viewKnownBigLedgerPeers" viewKnownSharedPeers viewKnownBigLedgerPeers
+      .&&. disjointSetsProperty "viewKnownBootstrapPeers-viewKnownBigLedgerPeers" viewKnownBootstrapPeers viewKnownBigLedgerPeers
+
+    viewSizeInvariant :: PeerSelectionSetsWithSizes PeerAddr
+                      -> Property
+    viewSizeInvariant PeerSelectionView {..} =
+            counterexample "viewRootPeers"
+            (Set.size (fst viewRootPeers) === snd viewRootPeers)
+
+      .&&.  counterexample "viewKnownPeers"
+            (Set.size (fst viewKnownPeers) === snd viewKnownPeers)
+
+      .&&. counterexample "viewAvailableToConnectPeers"
+           (Set.size (fst viewAvailableToConnectPeers) === snd viewAvailableToConnectPeers)
+      .&&. counterexample "viewColdPeersPromotions"
+           (Set.size (fst viewColdPeersPromotions) === snd viewColdPeersPromotions)
+      .&&. counterexample "viewEstablishedPeers"
+           (Set.size (fst viewEstablishedPeers) === snd viewEstablishedPeers)
+      .&&. counterexample "viewWarmPeersDemotions"
+           (Set.size (fst viewWarmPeersDemotions) === snd viewWarmPeersDemotions)
+      .&&. counterexample "viewWarmPeersPromotions"
+           (Set.size (fst viewWarmPeersPromotions) === snd viewWarmPeersPromotions)
+      .&&. counterexample "viewActivePeers"
+           (Set.size (fst viewActivePeers) === snd viewActivePeers)
+      .&&. counterexample "viewActivePeersDemotions"
+           (Set.size (fst viewActivePeersDemotions) === snd viewActivePeersDemotions)
+
+      .&&. counterexample "viewKnownBigLedgerPeers"
+           (Set.size (fst viewKnownBigLedgerPeers) === snd viewKnownBigLedgerPeers)
+      .&&. counterexample "viewAvailableToConnectBigLedgerPeers"
+           (Set.size (fst viewAvailableToConnectBigLedgerPeers) === snd viewAvailableToConnectBigLedgerPeers)
+      .&&. counterexample "viewColdBigLedgerPeersPromotions"
+           (Set.size (fst viewColdBigLedgerPeersPromotions) === snd viewColdBigLedgerPeersPromotions)
+      .&&. counterexample "viewEstablishedBigLedgerPeers"
+           (Set.size (fst viewEstablishedBigLedgerPeers) === snd viewEstablishedBigLedgerPeers)
+      .&&. counterexample "viewWarmBigLedgerPeersDemotions"
+           (Set.size (fst viewWarmBigLedgerPeersDemotions) === snd viewWarmBigLedgerPeersDemotions)
+      .&&. counterexample "viewWarmBigLedgerPeersPromotions"
+           (Set.size (fst viewWarmBigLedgerPeersPromotions) === snd viewWarmBigLedgerPeersPromotions)
+      .&&. counterexample "viewActiveBigLedgerPeers"
+           (Set.size (fst viewActiveBigLedgerPeers) === snd viewActiveBigLedgerPeers)
+      .&&. counterexample "viewActiveBigLedgerPeersDemotions"
+           (Set.size (fst viewActiveBigLedgerPeersDemotions) === snd viewActiveBigLedgerPeersDemotions)
+
+      .&&. counterexample "viewKnownLocalRootPeers"
+           (Set.size (fst viewKnownLocalRootPeers) === snd viewKnownLocalRootPeers)
+      .&&. counterexample "viewAvailableToConnectLocalRootPeers"
+           (Set.size (fst viewAvailableToConnectLocalRootPeers) === snd viewAvailableToConnectLocalRootPeers)
+      .&&. counterexample "viewColdLocalRootPeersPromotions"
+           (Set.size (fst viewColdLocalRootPeersPromotions) === snd viewColdLocalRootPeersPromotions)
+      .&&. counterexample "viewEstablishedLocalRootPeers"
+           (Set.size (fst viewEstablishedLocalRootPeers) === snd viewEstablishedLocalRootPeers)
+      .&&. counterexample "viewWarmLocalRootPeersPromotions"
+           (Set.size (fst viewWarmLocalRootPeersPromotions) === snd viewWarmLocalRootPeersPromotions)
+      .&&. counterexample "viewActiveLocalRootPeers"
+           (Set.size (fst viewActiveLocalRootPeers) === snd viewActiveLocalRootPeers)
+      .&&. counterexample "viewActiveLocalRootPeersDemotions"
+           (Set.size (fst viewActiveLocalRootPeersDemotions) === snd viewActiveLocalRootPeersDemotions)
+
+      .&&. counterexample "viewKnownSharedPeers"
+           (Set.size (fst viewKnownSharedPeers) === snd viewKnownSharedPeers)
+      .&&. counterexample "viewColdSharedPeersPromotions"
+           (Set.size (fst viewColdSharedPeersPromotions) === snd viewColdSharedPeersPromotions)
+      .&&. counterexample "viewEstablishedSharedPeers"
+           (Set.size (fst viewEstablishedSharedPeers) === snd viewEstablishedSharedPeers)
+      .&&. counterexample "viewWarmSharedPeersDemotions"
+           (Set.size (fst viewWarmSharedPeersDemotions) === snd viewWarmSharedPeersDemotions)
+      .&&. counterexample "viewWarmSharedPeersPromotions"
+           (Set.size (fst viewWarmSharedPeersPromotions) === snd viewWarmSharedPeersPromotions)
+      .&&. counterexample "viewActiveSharedPeers"
+           (Set.size (fst viewActiveSharedPeers) === snd viewActiveSharedPeers)
+      .&&. counterexample "viewActiveSharedPeersDemotions"
+           (Set.size (fst viewActiveSharedPeersDemotions) === snd viewActiveSharedPeersDemotions)
+
+      .&&. counterexample "viewKnownBootstrapPeers"
+           (Set.size (fst viewKnownBootstrapPeers) === snd viewKnownBootstrapPeers)
+      .&&. counterexample "viewColdBootstrapPeersPromotions"
+           (Set.size (fst viewColdBootstrapPeersPromotions) === snd viewColdBootstrapPeersPromotions)
+      .&&. counterexample "viewEstablishedBootstrapPeers"
+           (Set.size (fst viewEstablishedBootstrapPeers) === snd viewEstablishedBootstrapPeers)
+      .&&. counterexample "viewWarmBootstrapPeersDemotions"
+           (Set.size (fst viewWarmBootstrapPeersDemotions) === snd viewWarmBootstrapPeersDemotions)
+      .&&. counterexample "viewWarmBootstrapPeersPromotions"
+           (Set.size (fst viewWarmBootstrapPeersPromotions) === snd viewWarmBootstrapPeersPromotions)
+      .&&. counterexample "viewActiveBootstrapPeers"
+           (Set.size (fst viewActiveBootstrapPeers) === snd viewActiveBootstrapPeers)
+      .&&. counterexample "viewActiveBootstrapPeersDemotions"
+           (Set.size (fst viewActiveBootstrapPeersDemotions) === snd viewActiveBootstrapPeersDemotions)
+
+
 -- We start with basic properties in the style of "never does bad things"
 -- and progress to properties that check that it "eventually does good things".
 --

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

@@ -19,6 +19,7 @@ module Test.Ouroboros.Network.PeerSelection.MockEnvironment
   , TraceMockEnv (..)
   , TestTraceEvent (..)
   , selectGovernorEvents
+  , selectGovernorStateEvents
   , selectPeerSelectionTraceEvents
   , selectPeerSelectionTraceEventsUntil
   , peerShareReachablePeers
@@ -719,6 +720,11 @@ selectGovernorEvents :: [(Time, TestTraceEvent)]
                      -> [(Time, TracePeerSelection PeerAddr)]
 selectGovernorEvents trace = [ (t, e) | (t, GovernorEvent e) <- trace ]
 
+selectGovernorStateEvents :: [(Time, TestTraceEvent)]
+                          -> [(Time, DebugPeerSelection PeerAddr)]
+selectGovernorStateEvents trace = [ (t, e) | (t, GovernorDebug e) <- trace ]
+
+
 
 --
 -- QuickCheck instances

ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs

@@ -103,7 +103,7 @@ import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers)
 import Ouroboros.Network.PeerSelection.Governor qualified as Governor
 import Ouroboros.Network.PeerSelection.Governor.Types
            (ChurnMode (ChurnModeNormal), DebugPeerSelection (..),
-           PeerSelectionActions, PeerSelectionCounters (..),
+           PeerSelectionActions, PeerSelectionCounters,
            PeerSelectionPolicy (..), PeerSelectionState,
            TracePeerSelection (..), emptyPeerSelectionCounters,
            emptyPeerSelectionState)

ouroboros-network/src/Ouroboros/Network/PeerSelection/Churn.hs

@@ -1,9 +1,14 @@
 {-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
+#if __GLASGOW_HASKELL__ < 904
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+#endif
+
 -- | This subsystem manages the discovery and selection of /upstream/ peers.
 --
 module Ouroboros.Network.PeerSelection.Churn

ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs

@@ -30,12 +30,15 @@ module Ouroboros.Network.PeerSelection.Governor
   , PeerSelectionState (..)
   , PublicPeerSelectionState (..)
   , makePublicPeerSelectionStateVar
-  , PeerSelectionCounters (..)
+  , PeerSelectionView (..)
+  , PeerSelectionCounters
+  , PeerSelectionSetsWithSizes
   , peerSelectionStateToCounters
   , emptyPeerSelectionCounters
   , nullPeerSelectionTargets
   , emptyPeerSelectionState
   , ChurnMode (..)
+  , peerSelectionStateToView
   ) where
 
 import Data.Foldable (traverse_)

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

@@ -245,7 +245,6 @@ belowTargetOther actions
                    policyPickWarmPeersToPromote
                  }
                  st@PeerSelectionState {
-                   publicRootPeers,
                    localRootPeers,
                    establishedPeers,
                    activePeers,
@@ -302,13 +301,13 @@ belowTargetOther actions
   | otherwise
   = GuardedSkip Nothing
   where
-    PeerSelectionCounters {
-        numberOfActivePeers         = numActivePeers,
-        numberOfWarmPeersPromotions = numPromoteInProgress
+    PeerSelectionView {
+        viewActivePeers         = (_, numActivePeers),
+        viewWarmPeersPromotions = (_, numPromoteInProgress),
+        viewKnownBigLedgerPeers = (bigLedgerPeersSet, _)
       }
       =
-      peerSelectionStateToCounters st
-    bigLedgerPeersSet = PublicRootPeers.getBigLedgerPeers publicRootPeers
+      peerSelectionStateToView st
 
 
 jobPromoteWarmPeer :: forall peeraddr peerconn m.

ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/BigLedgerPeers.hs

@@ -24,7 +24,6 @@ import Ouroboros.Network.PeerSelection.LedgerPeers (LedgerPeersKind (..))
 import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
 import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers)
 import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
-import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers
 import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers
 import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers
 
@@ -183,7 +182,6 @@ aboveTarget PeerSelectionPolicy {policyPickColdPeersToForget}
             st@PeerSelectionState {
                  publicRootPeers,
                  knownPeers,
-                 establishedPeers,
                  inProgressPromoteCold,
                  targets = PeerSelectionTargets {
                              targetNumberOfKnownBigLedgerPeers
@@ -228,18 +226,9 @@ aboveTarget PeerSelectionPolicy {policyPickColdPeersToForget}
   where
     bigLedgerPeersSet = PublicRootPeers.getBigLedgerPeers publicRootPeers
 
-    PeerSelectionCounters {
-        numberOfKnownBigLedgerPeers = numKnownBigLedgerPeers
+    PeerSelectionView {
+        viewKnownBigLedgerPeers       = (_, numKnownBigLedgerPeers),
+        viewEstablishedBigLedgerPeers = (establishedBigLedgerPeers, numEstablishedBigLedgerPeers)
       }
       =
-      peerSelectionStateToCounters st
-
-    establishedBigLedgerPeers :: Set peeraddr
-    establishedBigLedgerPeers = EstablishedPeers.toSet establishedPeers
-                                `Set.intersection`
-                                bigLedgerPeersSet
-
-    -- TODO: we should compute this with `PeerSelectionCounters`, but we also
-    -- need to return the `establishedBigLedgerPeers` set.
-    numEstablishedBigLedgerPeers :: Int
-    numEstablishedBigLedgerPeers = Set.size establishedBigLedgerPeers
+      peerSelectionStateToView st