peer-selection: added tests for promiscuous mode

* Extended the `GovernorMockEnvironment` with a `TimedScript UseLedgerPeers`.
* added `prop_governor_promiscuous_mode`

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

@@ -86,6 +86,8 @@ instance Arbitrary ArbitraryLedgerStateJudgement where
     shrink (ArbitraryLedgerStateJudgement TooOld)      =
       []
 
+-- TODO: import the `SlotNo` instance from
+-- `Test.Ouroboros.Network.PeerSelection.Instances`
 newtype ArbitrarySlotNo =
   ArbitrarySlotNo {
     getArbitrarySlotNo :: SlotNo

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

@@ -190,6 +190,7 @@ tests =
       , testProperty "node uses ledger peers in non-sensitive mode"
                      prop_governor_uses_ledger_peers
       ]
+    , testProperty "promiscuous mode" prop_governor_promiscuous_mode
     ]
   , testGroup "issues"
     [ testProperty "3233" prop_issue_3233
@@ -761,6 +762,7 @@ envEventCredits  TraceEnvActivatePeer {}        = 0
 envEventCredits  TraceEnvDeactivatePeer {}      = 0
 envEventCredits  TraceEnvCloseConn {}           = 0
 
+envEventCredits  TraceEnvUseLedgerPeers {}      = 30
 envEventCredits  TraceEnvSetLedgerStateJudgement {} = 30
 
 envEventCredits  TraceEnvSetUseBootstrapPeers {} = 30
@@ -3426,6 +3428,77 @@ prop_governor_uses_ledger_peers env =
      in counterexample (intercalate "\n" $ map show $ usesLedgerPeers)
       $ all snd usesLedgerPeers
 
+
+prop_governor_promiscuous_mode :: GovernorMockEnvironment -> Property
+prop_governor_promiscuous_mode env =
+    let events = Signal.eventsFromListUpToTime (Time (10 * 60 * 60))
+               . selectPeerSelectionTraceEvents
+               . runGovernorInMockEnvironment
+               $ env
+
+        counters :: Signal (PeerSelectionSetsWithSizes PeerAddr)
+        counters =
+          selectGovState peerSelectionStateToView events
+
+        -- accumulate local roots
+        localRoots :: Signal (Set PeerAddr)
+        localRoots =
+            Signal.keyedUntil
+              (\case
+                Just (GovernorEvent (TraceLocalRootPeersChanged a _)) -> LocalRootPeers.keysSet a
+                Just (MockEnvEvent (TraceEnvSetLocalRoots a)) -> LocalRootPeers.keysSet a
+                _ -> Set.empty
+              )
+              (\_ -> Set.empty)
+              (\_ -> False)
+          . Signal.fromChangeEvents Nothing
+          . fmap Just
+          $ events
+
+        publicRoots :: Signal (Set PeerAddr)
+        publicRoots =
+            Signal.keyedUntil
+              PublicRootPeers.toSet
+              (\_ -> Set.empty)
+              (\_ -> False)
+          . selectGovState Governor.publicRootPeers
+          $ events
+
+        promiscuousMode :: Signal Bool
+        promiscuousMode =
+            Signal.fromChangeEvents True
+          $ selectGovPromiscuousMode events
+
+    in counterexample (intercalate "\n" $ show <$> Signal.eventsToList events)
+     $ signalProperty 20 show
+        (\(cs, localRootSet, publicRootSet, pm) ->
+          if not pm
+            then
+            -- we need to remove local and public roots.  They are changing
+            -- over time, and a node might keep using them, event though the
+            -- node is configured as a non-promiscuous node.
+            --
+            -- This makes this test only effective if a node starts in
+            -- non-promiscuous mode, until it is reconfigured.  This can
+            -- discover some bugs in `readPromiscuousMode` but certainly not
+            -- all.
+            --
+            -- TODO: write a more effective test.
+               Set.null (fst (viewKnownBootstrapPeers cs)
+                          Set.\\ localRootSet
+                          Set.\\ publicRootSet)
+            && Set.null (fst (viewKnownBigLedgerPeers cs)
+                          Set.\\ localRootSet
+                          Set.\\ publicRootSet)
+            && Set.null (fst (viewKnownSharedPeers cs)
+                          Set.\\ localRootSet
+                          Set.\\ publicRootSet)
+          else True)
+        ((,,,) <$> counters
+               <*> localRoots
+               <*> publicRoots
+               <*> promiscuousMode)
+
 --
 -- Utils for properties
 --
@@ -3444,6 +3517,18 @@ selectGovEvents = Signal.selectEvents
                     (\case GovernorEvent e -> Just $! e
                            _               -> Nothing)
 
+selectGovCounters :: Events TestTraceEvent
+                  -> Events PeerSelectionCounters
+selectGovCounters = Signal.selectEvents
+                      (\case GovernorCounters e -> Just $! e
+                             _                  -> Nothing)
+
+selectGovPromiscuousMode :: Events TestTraceEvent
+                         -> Events Bool
+selectGovPromiscuousMode = Signal.selectEvents
+                             (\case GovernorPromiscuousMode e -> Just $! e
+                                    _                         -> Nothing)
+
 selectGovState :: Eq a
                => (forall peerconn. Governor.PeerSelectionState PeerAddr peerconn -> a)
                -> Events TestTraceEvent
@@ -3601,6 +3686,7 @@ prop_issue_3550 = prop_governor_target_established_below defaultMaxTime $
       pickColdPeersToForget = Script (PickFirst :| []),
       peerSharingFlag = PeerSharingEnabled,
       useBootstrapPeers = Script ((DontUseBootstrapPeers, NoDelay) :| []),
+      useLedgerPeers = Script ((UseLedgerPeers Always, NoDelay) :| []),
       ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| [])
     }
 
@@ -3637,6 +3723,7 @@ prop_issue_3515 = prop_governor_nolivelock $
       pickColdPeersToForget = Script (PickFirst :| []),
       peerSharingFlag = PeerSharingEnabled,
       useBootstrapPeers = Script ((DontUseBootstrapPeers, NoDelay) :| []),
+      useLedgerPeers = Script ((UseLedgerPeers Always, NoDelay) :| []),
       ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| [])
     }
 
@@ -3673,6 +3760,7 @@ prop_issue_3494 = prop_governor_nofail $
       pickColdPeersToForget = Script (PickFirst :| []),
       peerSharingFlag = PeerSharingEnabled,
       useBootstrapPeers = Script ((DontUseBootstrapPeers, NoDelay) :| []),
+      useLedgerPeers = Script ((UseLedgerPeers Always, NoDelay) :| []),
       ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| [])
     }
 
@@ -3725,6 +3813,7 @@ prop_issue_3233 = prop_governor_nolivelock $
       pickColdPeersToForget = Script (PickFirst :| []),
       peerSharingFlag = PeerSharingEnabled,
       useBootstrapPeers = Script ((DontUseBootstrapPeers, NoDelay) :| []),
+      useLedgerPeers = Script ((UseLedgerPeers Always, NoDelay) :| []),
       ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| [])
     }
 

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

@@ -1,6 +1,8 @@
+{-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -16,19 +18,22 @@ module Test.Ouroboros.Network.PeerSelection.Instances
   ) where
 
 import Data.Text.Encoding (encodeUtf8)
-import Data.Word (Word32)
+import Data.Word (Word32, Word64)
+
+import Cardano.Slotting.Slot (SlotNo (..))
 
 import Ouroboros.Network.PeerSelection.Governor
 
 import Data.Hashable
 import Data.IP qualified as IP
+import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
+import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..),
+           UseLedgerPeers (..))
 import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
 import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
+import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
 import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint (..),
            RelayAccessPoint (..))
-
-import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
-import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
 import Ouroboros.Network.Testing.Utils (ShrinkCarefully, prop_shrink_nonequal,
            prop_shrink_valid)
 import Test.QuickCheck
@@ -51,7 +56,7 @@ instance Arbitrary PeerAddr where
   arbitrary = PeerAddr <$> arbitrarySizedNatural
   shrink _  = []
 
-
+deriving via Word64 instance Arbitrary SlotNo
 
 instance Arbitrary PeerAdvertise where
   arbitrary = elements [ DoAdvertisePeer, DoNotAdvertisePeer ]
@@ -64,6 +69,11 @@ instance Arbitrary PeerSharing where
   shrink PeerSharingDisabled = []
   shrink PeerSharingEnabled  = [PeerSharingDisabled]
 
+instance Arbitrary AfterSlot where
+  arbitrary = oneof [ pure Always
+                    , After <$> arbitrary
+                    ]
+
 instance Arbitrary UseBootstrapPeers where
   arbitrary = frequency [ (1, pure DontUseBootstrapPeers)
                         , (1, UseBootstrapPeers <$> arbitrary)
@@ -72,6 +82,12 @@ instance Arbitrary UseBootstrapPeers where
   shrink DontUseBootstrapPeers = []
   shrink (UseBootstrapPeers _) = [DontUseBootstrapPeers]
 
+instance Arbitrary UseLedgerPeers where
+    arbitrary = frequency
+      [ (2, pure DontUseLedgerPeers)
+      , (8, UseLedgerPeers <$> arbitrary)
+      ]
+
 instance Arbitrary PeerTrustable where
   arbitrary = elements [ IsNotTrustable, IsTrustable ]