Fixed peerselection test failure

cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs

@@ -1814,6 +1814,8 @@ prop_peer_selection_trace_coverage defaultBearerInfo diffScript =
         "TraceDemoteAsynchronous"
       peerSelectionTraceMap TraceDemoteLocalAsynchronous {}          =
         "TraceDemoteLocalAsynchronous"
+      peerSelectionTraceMap TraceForgottenPeers {}                   =
+        "TraceForgottenPeers"
       peerSelectionTraceMap TraceGovernorWakeup                      =
         "TraceGovernorWakeup"
       peerSelectionTraceMap TraceChurnWait {}                        =

cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
+-- OverloadedStrings is useful when copy pasting counterexamples
+{-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -970,6 +972,7 @@ traceNum TraceDebugState {}                                   = 53
 traceNum TraceChurnAction {}                                  = 54
 traceNum TraceChurnTimeout {}                                 = 55
 traceNum TraceVerifyPeerSnapshot {}                           = 56
+traceNum TraceForgottenPeers {}                               = 57
 
 allTraceNames :: Map Int String
 allTraceNames =
@@ -1031,6 +1034,7 @@ allTraceNames =
    , (54, "TraceChurnAction")
    , (55, "TraceChurnTimeout")
    , (56, "TraceVerifyPeerSnapshot")
+   , (57, "TraceForgottenPeers")
    ]
 
 
@@ -2129,7 +2133,7 @@ prop_governor_target_known_4_results_used (MaxTime maxTime) env =
 
 
 -- | The governor should not shrink its known peer set except when it is above
--- the target size.
+-- the target size or the peer failed too many times.
 --
 -- We derive a number of signals:
 --
@@ -2149,14 +2153,20 @@ prop_governor_target_known_4_results_used (MaxTime maxTime) env =
 --
 prop_governor_target_known_5_no_shrink_below :: MaxTime -> GovernorMockEnvironment -> Property
 prop_governor_target_known_5_no_shrink_below (MaxTime maxTime) env =
-    let events = Signal.eventsFromListUpToTime maxTime
+    let events :: Events (TestTraceEvent ExtraState PeerTrustable (Cardano.ExtraPeers PeerAddr))
+        events = Signal.eventsFromListUpToTime maxTime
                . selectPeerSelectionTraceEvents
                    @Cardano.ExtraState
                    @PeerTrustable
                    @(Cardano.ExtraPeers PeerAddr)
                . runGovernorInMockEnvironment
                $ env
 
+        -- | Forgotten peers due to too many failures.
+        --
+        forgottenPeers :: Signal (Set PeerAddr)
+        forgottenPeers = selectForgottenPeers events
+
         govTargetsSig :: Signal Int
         govTargetsSig =
           selectGovState (targetNumberOfKnownPeers . Governor.targets)
@@ -2196,16 +2206,20 @@ prop_governor_target_known_5_no_shrink_below (MaxTime maxTime) env =
           . Signal.difference
               -- We subtract all big ledger peers.  This is because we might
               -- first satisfy the target of known peers, and then learn that
-              -- one of them was a big ledger peers. We also subtract
-              -- bootstrap peers. This would be a fake shrink of known non
-              -- big ledger peers.
+              -- one of them was a big ledger peer. We also subtract
+              -- bootstrap peers. This would be a fake shrink of known non big
+              -- ledger peers.
               --
               -- By subtracting a sum of `y` and `y'` we also do not account
               -- forgetting big ledger peers.
-              (\(x,y,z) (x',y',z') -> x Set.\\ x' Set.\\ y Set.\\ y' Set.\\ z Set.\\ z')
-          $ (,,) <$> govKnownPeersSig
-                 <*> bigLedgerPeersSig
-                 <*> bootstrapPeersSig
+              --
+              -- Subtract `forgottenPeers`: peer selection can go below the
+              -- target, but only if a peer fails too many times.
+              (\(x,y,z,f) (x',y',z',f') -> x Set.\\ x' Set.\\ y Set.\\ y' Set.\\ z Set.\\ z' Set.\\ f Set.\\ f')
+          $ (,,,) <$> govKnownPeersSig
+                  <*> bigLedgerPeersSig
+                  <*> bootstrapPeersSig
+                  <*> forgottenPeers
 
         unexpectedShrink :: Signal Bool
         unexpectedShrink =
@@ -2223,15 +2237,16 @@ prop_governor_target_known_5_no_shrink_below (MaxTime maxTime) env =
             <*> govKnownPeersSig
             <*> knownPeersShrinksSig
 
-     in counterexample
-          "\nSignal key: (target, known peers, shrinks, unexpected)" $
-
+     in counterexample (Signal.ppEvents events) $
+        counterexample
+          "Signal key: (target, known peers, shrinks, unexpected)" $
         signalProperty 20 show
-          (\(_,_,_,unexpected) -> not unexpected)
-          ((,,,) <$> govTargetsSig
-                 <*> govKnownPeersSig
-                 <*> knownPeersShrinksSig
-                 <*> unexpectedShrink)
+          (\(_,_,_,_,unexpected) -> not unexpected)
+          ((,,,,) <$> govTargetsSig
+                  <*> govKnownPeersSig
+                  <*> knownPeersShrinksSig
+                  <*> forgottenPeers
+                  <*> unexpectedShrink)
 
 -- | Like 'prop_governor_target_known_5_no_shrink_below' but for big ledger
 -- peers.

cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/MockEnvironment.hs

@@ -801,6 +801,7 @@ tracerTracePeerSelection = contramap f tracerTestTraceEvent
     f a@(TraceDemoteAsynchronous !_)                               = GovernorEvent a
     f a@(TraceDemoteLocalAsynchronous !_)                          = GovernorEvent a
     f a@(TraceDemoteBigLedgerPeersAsynchronous !_)                 = GovernorEvent a
+    f a@(TraceForgottenPeers !_)                                   = GovernorEvent a
     f a@TraceGovernorWakeup                                        = GovernorEvent a
     f a@(TraceChurnWait !_)                                        = GovernorEvent a
     f a@(ExtraTrace

cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/Utils.hs

@@ -82,6 +82,15 @@ selectEnvTargets f =
   . selectEnvEvents
 
 
+selectForgottenPeers :: Events (TestTraceEvent extraState extraFlags extraPeers)
+                     -> Signal (Set PeerAddr)
+selectForgottenPeers =
+    Signal.fromChangeEvents Set.empty
+  . Signal.selectEvents
+      (\case GovernorEvent (TraceForgottenPeers peers) -> Just $! peers
+             _                                         -> Nothing
+      )
+
 -- | filter big ledger peers
 --
 takeBigLedgerPeers

ouroboros-network/changelog.d/20260319_132736_coot_known_peers_failure.md

@@ -0,0 +1,21 @@
+<!--
+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
+
+- Added `TraceForgottenPeers` to `TracePeerSelection`
+
+### Non-Breaking
+
+- Added `Test.Ouroboros.Network.Data.Signal.ppEvents`
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->

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

@@ -185,8 +185,8 @@ connections PeerSelectionActions{
                               now
                               policyMaxConnectionRetries
                               (Map.keysSet demotedToCold)
-                              ( \p -> LocalRootPeers.member p localRootPeers ||
-                                (memberExtraPeers p (PublicRootPeers.getExtraPeers publicRootPeers))
+                              ( \p -> LocalRootPeers.member p localRootPeers
+                                   || memberExtraPeers p (PublicRootPeers.getExtraPeers publicRootPeers)
                               )
                               (\p _ ->
                                   case Map.lookup p demotedToCold of
@@ -219,7 +219,10 @@ connections PeerSelectionActions{
                               | not $ null publicRootDemotions ]
                            <> [ TraceDemoteBigLedgerPeersAsynchronous
                                   bigLedgerPeersDemotions
-                              | not $ null bigLedgerPeersDemotions ],
+                              | not $ null bigLedgerPeersDemotions ]
+                           <> [ TraceForgottenPeers forgottenPeers
+                              | not $ null forgottenPeers
+                              ],
               decisionJobs  = [],
               decisionState = st {
                                 activePeers       = activePeers',

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

@@ -1790,6 +1790,9 @@ data TracePeerSelection extraDebugState extraFlags extraPeers peeraddr =
      | TraceDemoteLocalAsynchronous (Map peeraddr (PeerStatus, Maybe RepromoteDelay))
      | TraceDemoteBigLedgerPeersAsynchronous
                                     (Map peeraddr (PeerStatus, Maybe RepromoteDelay))
+       -- | Set of forgotten peers due to too many failures (connection errors,
+       -- asynchronous demotions, etc.)
+     | TraceForgottenPeers (Set peeraddr)
 
      | TraceGovernorWakeup
 

ouroboros-network/lib/Ouroboros/Network/PeerSelection/State/KnownPeers.hs

@@ -449,6 +449,7 @@ reportFailures :: Ord peeraddr
                -- ^ calculate delay from failure count
                -> KnownPeers peeraddr
                -> (KnownPeers peeraddr, Set peeraddr)
+               -- ^ new known set, set of forgotten peers
 reportFailures now
                maxFail
                peers
@@ -466,7 +467,7 @@ reportFailures now
     -- filter out peers with too high fail count
         (peers'', forgets) = Map.partitionWithKey partFn peers'
     -- calculate reconnect times
-        times = Map.mapWithKey (\p fc -> (calcDelay p fc) `addTime` now) peers''
+        times = Map.mapWithKey (\p fc -> calcDelay p fc `addTime` now) peers''
     -- set next connect times.
         knownPeers'' = delete (Map.keysSet forgets) knownPeers' {
           availableToConnect =

ouroboros-network/orphan-instances/Ouroboros/Network/OrphanInstances.hs

@@ -1133,6 +1133,10 @@ instance ( ToJSON extraDebugState
     object [ "kind" .= String "DemoteBigLedgerPeersAsynchronous"
            , "state" .= msp
            ]
+  toJSON (TraceForgottenPeers peers) =
+    object [ "kind" .= String "ForgottenPeers"
+           , "peers" .= peers
+           ]
   toJSON TraceGovernorWakeup =
     object [ "kind" .= String "GovernorWakeup"
            ]

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

@@ -12,6 +12,7 @@ module Test.Ouroboros.Network.Data.Signal
   , eventsFromListUpToTime
   , eventsToList
   , eventsToListWithId
+  , ppEvents
   , selectEvents
     -- * Low level access
   , primitiveTransformEvents
@@ -66,6 +67,7 @@ import Data.Set (Set)
 import Data.Set qualified as Set
 import Deque.Lazy (Deque)
 import Deque.Lazy qualified as Deque
+import Text.Printf (printf)
 
 import Control.Monad.Class.MonadTime.SI (DiffTime, Time (..), addTime)
 
@@ -111,6 +113,12 @@ newtype Events a = Events [E a]
   deriving (Show, Functor, Foldable)
   deriving newtype (Semigroup, Monoid)
 
+ppEvents :: Show a => Events a -> String
+ppEvents (Events es) =
+  unlines [ printf "%-20s %s" (show t) (show a)
+          | E (TS (Time t) _) a <- es
+          ]
+
 -- | Construct 'Events' from a time series.
 --
 eventsFromList :: [(Time, a)] -> Events a
@@ -565,18 +573,24 @@ signalProperty' atMost showSignalValue p =
     go !_ !_ []                  = pure $ property True
     go !n !recent ((t, x) : txs) = (.&&.) . counterexample details <$> p x <*> next
       where
+        recent'
+          | n < atMost =              Deque.snoc (t,x) recent
+          | otherwise  = Deque.tail $ Deque.snoc (t,x) recent
         next
-          | n < atMost = go (n+1) (              Deque.snoc (t,x)  recent) txs
-          | otherwise  = go n     ((Deque.tail . Deque.snoc (t,x)) recent) txs
+          | n < atMost = go (n+1) recent' txs
+          | otherwise  = go n     recent' txs
 
         details =
-          unlines [ "Last " ++ show atMost ++ " signal values:"
-                  , unlines [ show t' ++ "\t@ " ++ showSignalValue x'
-                            | (Time t',x') <- Deque.toList recent ]
-                  , "Property violated at: " ++ show t
-                  , "Invalid signal value:"
-                  , showSignalValue x
-                  ]
+          unlines $
+            [ "Last " ++ show atMost ++ " signal values:"
+            ]
+            ++
+            [ printf "%-18s %s" (show t') (showSignalValue x')
+            | (Time t',x') <- Deque.toList recent'
+            ]
+            ++
+            [ "Property violated at: " ++ case t of Time a -> show a
+            ]
 
 --
 -- Utils

ouroboros-network/tracing/Ouroboros/Network/Tracing/PeerSelection/Governor/TracePeerSelection.hs

@@ -309,6 +309,10 @@ instance ( Show extraDebugState
     mconcat [ "kind" .= String "DemoteBigLedgerPeerAsynchronous"
              , "state" .= toJSON msp
              ]
+  forMachine _dtal (TraceForgottenPeers peers) =
+    mconcat [ "kind" .= String "ForgottenPeers"
+            , "peers" .= peers
+            ]
   forMachine _dtal TraceGovernorWakeup =
     mconcat [ "kind" .= String "GovernorWakeup"
              ]
@@ -485,6 +489,8 @@ instance MetaTrace (ToExtraTrace extraPeers)
       Namespace [] ["DemoteLocalAsynchronous"]
     namespaceFor TraceDemoteBigLedgerPeersAsynchronous {} =
       Namespace [] ["DemoteBigLedgerPeersAsynchronous"]
+    namespaceFor TraceForgottenPeers {} =
+      Namespace [] ["TraceForgottenPeers"]
     namespaceFor TraceGovernorWakeup {}        =
       Namespace [] ["GovernorWakeup"]
     namespaceFor TraceChurnWait {}             =