inbound-governor: added tests for maturing peers logic

IntersectMBO · May 7, 2024 · 8e8913f · 8e8913f
1 parent b0d9345
commit 8e8913f
Show file tree

Hide file tree

Showing 2 changed files with 59 additions and 6 deletions.
diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs
@@ -53,7 +53,9 @@ import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe)
 import Data.Monoid (Sum (..))
 import Data.Monoid.Synchronisation (FirstToFinish (..))
+import Data.OrdPSQ (OrdPSQ)
 import Data.OrdPSQ qualified as OrdPSQ
+import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Typeable (Typeable)
 import System.Random (StdGen, mkStdGen, split)
@@ -133,6 +135,7 @@ tests =
     , testProperty "pruning"                prop_inbound_governor_pruning
     , testProperty "counters"               prop_inbound_governor_counters
     , testProperty "InboundGovernorState"   prop_inbound_governor_state
+    , testProperty "matured peers"          prop_inbound_governor_maturedPeers
     , testProperty "timeouts enforced"      prop_timeouts_enforced
     ]
   , testGroup "Server2"
@@ -2027,6 +2030,43 @@ prop_inbound_governor_pruning (Fixed rnd) serverAcc
                        events
                        (toNonFailing <$> attenuationMap)
 
+
+data FreshPeers peerAddr versionData =
+    FreshPeers Time
+               (OrdPSQ peerAddr Time versionData)
+
+    deriving Show
+
+
+instance (Arbitrary peerAddr, Arbitrary versionData, Ord peerAddr)
+    => Arbitrary (FreshPeers peerAddr versionData) where
+    arbitrary = FreshPeers <$> (mkTime <$> (arbitrary :: Gen Rational))
+                           <*> ( OrdPSQ.fromList . map (\(a, b, c) -> (a, mkTime b, c))
+                               <$> arbitrary)
+      where
+        mkTime :: Rational -> Time
+        mkTime = Time . realToFrac
+
+
+prop_inbound_governor_maturedPeers :: FreshPeers Int Int -> Property
+prop_inbound_governor_maturedPeers (FreshPeers now fresh) = property $
+         -- all peers which are kept as fresh are younger than `15min`
+         foldMap (\(addr, t, _) -> All $ counterexample (show (addr, t, now))
+                                       $ t >= (-delay) `addTime` now)
+                 (OrdPSQ.toList fresh')
+         -- peers are preserved
+      <> (All $ Map.keysSet matured <> keysSet fresh' === keysSet fresh)
+    where
+      (matured, fresh') = IG.maturedPeers now fresh
+
+      -- matured delay
+      delay :: DiffTime
+      delay = 15 * 60
+
+      keysSet :: Ord k => OrdPSQ k p v -> Set k
+      keysSet = Set.fromList . OrdPSQ.keys
+
+
 -- | Property wrapping `multinodeExperiment` that has a generator optimized for triggering
 -- pruning, and random generated number of connections hard limit.
 --

diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs
@@ -11,6 +11,7 @@
 
 -- 'runResponder' is using a redundant constraint.
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
 
 -- | Server implementation based on 'ConnectionManager'
 --
@@ -28,6 +29,8 @@ module Ouroboros.Network.InboundGovernor
     -- * Re-exports
   , Transition' (..)
   , TransitionTrace' (..)
+    -- * API's exported for testing purposes
+  , maturedPeers
   ) where
 
 import Control.Applicative (Alternative)
@@ -41,11 +44,13 @@ import Control.Monad.Class.MonadTime.SI
 import Control.Monad.Class.MonadTimer.SI
 import Control.Tracer (Tracer, traceWith)
 
+import Data.Bifunctor (first)
 import Data.ByteString.Lazy (ByteString)
 import Data.Cache
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Monoid.Synchronisation
+import Data.OrdPSQ (OrdPSQ)
 import Data.OrdPSQ qualified as OrdPSQ
 import Data.Set (Set)
 import Data.Set qualified as Set
@@ -174,12 +179,10 @@ withInboundGovernor trTracer tracer debugTracer inboundInfoChannel
         <- atomically $ runFirstToFinish $
                FirstToFinish  (
                  -- mark connections as mature
-                 case OrdPSQ.atMostView
-                       ((-inboundMaturePeerDelay) `addTime` time)
-                       (igsFreshDuplexPeers state) of
-                   ([], _)   -> retry
-                   (as, pq') -> let m = Map.fromList ((\(addr, _p, v) -> (addr, v)) <$> as)
-                                in pure $ MaturedDuplexPeers m pq'
+                 case maturedPeers time (igsFreshDuplexPeers state) of
+                   (as, _)     | Map.null as
+                               -> retry
+                   (as, fresh) -> pure $ MaturedDuplexPeers as fresh
                )
             <> Map.foldMapWithKey
                  (    firstMuxToFinish
@@ -569,6 +572,16 @@ runResponder mux
             startStrategy
             (runMiniProtocolCb responder responderContext)
 
+
+maturedPeers :: Ord peerAddr
+             => Time
+             -> OrdPSQ peerAddr Time versionData
+             -> (Map peerAddr versionData, OrdPSQ peerAddr Time versionData)
+maturedPeers time freshPeers =
+      first (Map.fromList . map (\(addr, _p, v) -> (addr, v)))
+    $ OrdPSQ.atMostView ((-inboundMaturePeerDelay) `addTime` time)
+                           freshPeers
+
 --
 -- Trace
 --