Churn test

cardano-diffusion/changelog.d/20260205_164419_edgr_churn_test.md

@@ -0,0 +1,17 @@
+<!--
+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
+
+- A bullet item for the Breaking category.
+
+-->
+### Non-Breaking
+
+- Added property that verifies target changes stay within acceptable bounds.
+- Updated `diffusionSimulation` to run with either the Cardano churn and Ouroboros churn.

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

@@ -21,6 +21,7 @@ module Test.Cardano.Network.Diffusion.Testnet (tests) where
 import Control.Arrow ((&&&))
 import Control.Exception (AssertionFailed (..), catch, displayException,
            evaluate, fromException)
+import Control.Monad (join)
 import Control.Monad.Class.MonadFork
 import Control.Monad.Class.MonadTest (exploreRaces)
 import Control.Monad.Class.MonadTime.SI
@@ -268,6 +269,10 @@ tests =
     , testGroup "Churn"
       [ testProperty "no timeouts" prop_churn_notimeouts_iosim
       , testProperty "steps" prop_churn_steps_iosim
+      , testProperty "targets bounds on Cardano"
+                     prop_churn_targets_bounds_cardano_iosim
+      , testProperty "targets bounds on Ouroboros"
+                     prop_churn_targets_bounds_ouroboros_iosim
       ]
     , testGroup "coverage"
       [ testProperty "server trace coverage"
@@ -328,9 +333,22 @@ testWithIOSim :: (SimTrace Void -> Int -> Property)
               -> DiffusionScript
               -- ^ sim-net configuration
               -> Property
-testWithIOSim prop traceNumber bi ds =
+testWithIOSim = testWithIOSim' diffusionSimulation
+
+testWithIOSim' :: (forall s. BearerInfo -> DiffusionScript -> IOSim s Void)
+               -- ^ diffusion simulation
+               -> (SimTrace Void -> Int -> Property)
+               -- ^ property to verify
+               -> Int
+               -- ^ number of trace events to analyse
+               -> AbsBearerInfo
+               -- ^ bearer configuration
+               -> DiffusionScript
+               -- ^ sim-net configuration
+               -> Property
+testWithIOSim' simulation prop traceNumber bi ds =
   let sim :: forall s . IOSim s Void
-      sim = diffusionSimulation (toBearerInfo bi)
+      sim = simulation (toBearerInfo bi)
                                 ds
       trace = runSimTrace sim
    in labelDiffusionScript ds $
@@ -4731,6 +4749,121 @@ prop_churn_notimeouts_iosim
   = testWithIOSim prop_churn_notimeouts long_trace
 
 
+-- Property that verifies target changes stay within acceptable bounds
+--
+-- This function checks that after churn:
+-- 1. New targets never exceed original targets
+-- 2. New targets never decrease by more than 20%
+prop_churn_targets_bounds :: [(NtNAddr, (PeerSelectionTargets, PeerSelectionTargets))]
+                                -> SimTrace Void
+                                -> Int
+                                -> Property
+prop_churn_targets_bounds baseTargetsMap ioSimTrace traceNumber =
+   let events :: [(NtNAddr, Time, DiffusionTestTrace)]
+       events = join . Trace.toList
+              . fmap (
+                     fmap (\(WithName node (WithTime t b)) -> (node, t, b))
+                    )
+              . splitWithNameTrace
+              . fmap (\(WithTime t (WithName name b)) -> WithName name (WithTime t b))
+              . withTimeNameTraceEvents
+                 @DiffusionTestTrace
+                 @NtNAddr
+              . Trace.take traceNumber
+              $ ioSimTrace
+
+       baseTargetsLookup = Map.fromList baseTargetsMap
+
+       -- Group events by node address
+       eventMap :: Map NtNAddr [(Time, DiffusionTestTrace)]
+       eventMap = foldr (\(node, t, trace) m ->
+                           case Map.lookup node m of
+                             Just ts -> Map.insert node ((t, trace):ts) m
+                             Nothing -> Map.insert node [(t, trace)] m
+                        ) Map.empty events
+
+       targetsChangeEventMap :: Map NtNAddr [PeerSelectionTargets]
+       targetsChangeEventMap =
+         catMaybes . fmap (\case
+                            (_, DiffusionPeerSelectionTrace (TraceTargetsChanged new))
+                                   -> Just new
+                            _other -> Nothing
+             ) <$> eventMap
+
+       -- Property that verifies target changes stay within acceptable bounds
+       --
+       -- This function checks that after churn:
+       -- 1. New targets never exceed original targets
+       -- 2. New targets never decrease by more than 20%
+       targetsChangeProperty :: PeerSelectionTargets -> PeerSelectionTargets -> Property
+       targetsChangeProperty
+         PeerSelectionTargets {
+           targetNumberOfKnownPeers                = knowns,
+           targetNumberOfEstablishedPeers          = establisheds,
+           targetNumberOfActivePeers               = actives,
+           targetNumberOfKnownBigLedgerPeers       = knownBigLedgers,
+           targetNumberOfEstablishedBigLedgerPeers = establishedBigLedgers,
+           targetNumberOfActiveBigLedgerPeers      = activeBigLedgers
+         }
+         PeerSelectionTargets {
+           targetNumberOfKnownPeers                = knowns',
+           targetNumberOfEstablishedPeers          = establisheds',
+           targetNumberOfActivePeers               = actives',
+           targetNumberOfKnownBigLedgerPeers       = knownBigLedgers',
+           targetNumberOfEstablishedBigLedgerPeers = establishedBigLedgers',
+           targetNumberOfActiveBigLedgerPeers      = activeBigLedgers'
+         }
+         = let -- 20% or at least one
+               decrease :: Int -> Int
+               decrease v = max 0 $ v - max 1 (v `div` 5)
+            in property (  actives' <= actives
+                        && actives' >= decrease actives
+                        && activeBigLedgers' <= activeBigLedgers
+                        && activeBigLedgers' >= decrease activeBigLedgers
+                        && knowns' <= knowns
+                        && knowns' >= decrease knowns
+                        && knownBigLedgers' <= knownBigLedgers
+                        && knownBigLedgers' >= decrease knownBigLedgers
+                        && establisheds' <= establisheds
+                        && establisheds' >= decrease establisheds
+                        && establishedBigLedgers' <= establishedBigLedgers
+                        && establishedBigLedgers' >= decrease establishedBigLedgers
+                        )
+
+       checks =
+         Map.foldrWithKey
+           (\ node targets p -> case Map.lookup node baseTargetsLookup of
+             Just bs@(base0, base1) ->
+               foldr (\ts p' -> counterexample ("Node: " ++ show node ++
+                                                "\nExpected: " ++ show bs ++
+                                                "\nActual: " ++ show ts ++
+                                                "\nAll rounds: " ++ show targets
+                                                ) (     targetsChangeProperty base0 ts
+                                                   .||. targetsChangeProperty base1 ts) .&&. p'
+                     ) p targets
+             Nothing -> counterexample ("No base targets for " <> show node) (property False)
+           )
+           (property True) targetsChangeEventMap
+
+
+   in checks
+
+prop_churn_targets_bounds_cardano_iosim
+  :: AbsBearerInfo -> DiffusionScript -> Property
+prop_churn_targets_bounds_cardano_iosim bi ds@(DiffusionScript _ _ nodes) =
+  let baseTargets = [ (naAddr nodeArgs, naPeerTargets nodeArgs)
+                    | (nodeArgs, _) <- nodes
+                    ]
+  in testWithIOSim (prop_churn_targets_bounds baseTargets) long_trace bi ds
+
+prop_churn_targets_bounds_ouroboros_iosim
+  :: AbsBearerInfo -> DiffusionScript -> Property
+prop_churn_targets_bounds_ouroboros_iosim bi ds@(DiffusionScript _ _ nodes) =
+  let baseTargets = [ (naAddr nodeArgs, naPeerTargets nodeArgs)
+                    | (nodeArgs, _) <- nodes
+                    ]
+  in testWithIOSim' diffusionSimulation' (prop_churn_targets_bounds baseTargets) long_trace bi ds
+
 -- | Verify that churn trace consists of repeated list of actions:
 --
 -- * `DecreasedActivePeers`

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

@@ -25,6 +25,7 @@ module Test.Cardano.Network.Diffusion.Testnet.Simulation
   , prop_diffusionScript_commandScript_valid
   , fixupCommands
   , diffusionSimulation
+  , diffusionSimulation'
   , Command (..)
     -- * Tracing
   , DiffusionTestTrace (..)
@@ -81,7 +82,7 @@ import Cardano.Network.Diffusion.Configuration qualified as Cardano
 import Cardano.Network.LedgerPeerConsensusInterface qualified as Cardano
 import Cardano.Network.LedgerStateJudgement
 import Cardano.Network.PeerSelection hiding (requestPublicRootPeers)
-import Cardano.Network.PeerSelection.Churn qualified as Churn
+import Cardano.Network.PeerSelection.Churn qualified as CardanoChurn
 import Cardano.Network.PeerSelection.ExtraRootPeers qualified as Cardano
 import Cardano.Network.PeerSelection.Governor.PeerSelectionActions qualified as Cardano
 import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Cardano hiding
@@ -109,6 +110,7 @@ import Ouroboros.Network.InboundGovernor qualified as IG
 import Ouroboros.Network.Mux (MiniProtocolLimits (..))
 import Ouroboros.Network.PeerSelection
 import Ouroboros.Network.PeerSelection qualified as Governor
+import Ouroboros.Network.PeerSelection.Churn qualified as OuroborosChurn
 import Ouroboros.Network.PeerSelection.LedgerPeers (accPoolStake)
 import Ouroboros.Network.Protocol.BlockFetch.Codec (byteLimitsBlockFetch,
            timeLimitsBlockFetch)
@@ -998,13 +1000,24 @@ ppDiffusionTestTrace (DiffusionMuxTrace tr)                         = show tr
 
 
 -- | Run an arbitrary topology in `IOSim`.
---
+-- This runs the simulator with the Cardano churn mechanism.
 diffusionSimulation
   :: BearerInfo
   -> DiffusionScript
   -> IOSim s Void
 diffusionSimulation bearerInfo diffusionScript =
-  diffusionSimulationM bearerInfo diffusionScript dynamicTracer
+  diffusionSimulationM bearerInfo diffusionScript dynamicTracer CardanoChurn
+
+-- | Run an arbitrary topology in `IOSim`.
+-- This runs the simulator with the Ouroboros churn mechanism.
+diffusionSimulation'
+  :: BearerInfo
+  -> DiffusionScript
+  -> IOSim s Void
+diffusionSimulation' bearerInfo diffusionScript =
+  diffusionSimulationM bearerInfo diffusionScript dynamicTracer OuroborosChurn
+
+data Churn = CardanoChurn | OuroborosChurn
 
 -- | Run an arbitrary topology in a generic monad `m`.
 --
@@ -1030,11 +1043,12 @@ diffusionSimulationM
   -> DiffusionScript
   -> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
   -- ^ timed trace of nodes in the system
+  -> Churn
   -> m Void
 diffusionSimulationM
   defaultBearerInfo
   (DiffusionScript simArgs dnsMapScript nodeArgs)
-  nodeTracer = do
+  nodeTracer churn = do
     connStateIdSupply <- atomically $ CM.newConnStateIdSupply Proxy
     -- TODO: we should use `snocket` per node, this will allow us to set up
     -- bearer info per node
@@ -1270,19 +1284,19 @@ diffusionSimulationM
                            | otherwise ->
                 return False
 
-          cardanoChurnArgs :: Churn.ExtraArguments m
+          cardanoChurnArgs :: CardanoChurn.ExtraArguments m
           cardanoChurnArgs =
-            Churn.ExtraArguments {
-              Churn.modeVar             = churnModeVar
-            , Churn.genesisPeerSelectionTargets
+            CardanoChurn.ExtraArguments {
+              CardanoChurn.modeVar             = churnModeVar
+            , CardanoChurn.genesisPeerSelectionTargets
                                         = snd peerTargets
-            , Churn.readUseBootstrap    = readUseBootstrapPeers
-            , Churn.consensusMode       = consensusMode
-            , Churn.tracerChurnMode     = (\s -> WithTime (Time (-1)) (WithName addr (DiffusionChurnModeTrace s)))
+            , CardanoChurn.readUseBootstrap    = readUseBootstrapPeers
+            , CardanoChurn.consensusMode       = consensusMode
+            , CardanoChurn.tracerChurnMode     = (\s -> WithTime (Time (-1)) (WithName addr (DiffusionChurnModeTrace s)))
                                             `contramap` nodeTracer
             }
 
-          arguments :: Node.Arguments (Churn.ExtraArguments m) PeerTrustable m
+          arguments :: Node.Arguments (CardanoChurn.ExtraArguments m) PeerTrustable m
           arguments =
             Node.Arguments
               { Node.aIPAddress            = addr
@@ -1304,7 +1318,7 @@ diffusionSimulationM
               , Node.aDebugTracer          = Tracer (\s -> do
                                               t <- getMonotonicTime
                                               traceWith nodeTracer $ WithTime t (WithName addr (DiffusionDebugTrace s)))
-              , Node.aExtraChurnArgs = cardanoChurnArgs
+              , Node.aExtraChurnArgs       = cardanoChurnArgs
               , Node.aTxDecisionPolicy     = txDecisionPolicy
               , Node.aTxs                  = txs
               }
@@ -1375,7 +1389,7 @@ diffusionSimulationM
           Cardano.cardanoPeerSelectionStatetoCounters
           (flip Cardano.ExtraPeers Set.empty)
           requestPublicRootPeers'
-          peerChurnGovernor
+          peerChurnGovernor'
           tracers
           ( contramap (DiffusionFetchTrace . (\(TraceLabelPeer _ a) -> a))
           . tracerWithName addr
@@ -1387,6 +1401,10 @@ diffusionSimulationM
                    >> throwIO e
         `finally`     traceWith (diffSimTracer addr) TrTerminated
 
+    peerChurnGovernor' = case churn of
+      OuroborosChurn -> OuroborosChurn.peerChurnGovernor
+      CardanoChurn   -> CardanoChurn.peerChurnGovernor
+
     domainResolver :: StrictTVar m MockDNSMap
                    -> DNSLookupType
                    -> [DomainAccessPoint]