Add diffusion property test

Author: the-headless-ghost

cardano-diffusion/changelog.d/20251108_103013_edgr_behind_firewall.md

@@ -5,13 +5,6 @@ Uncomment the section that is right (remove the HTML comment wrapper).
 For top level release notes, leave all the headers commented out.
 -->
 
-### Breaking
-
-- Modified `establishPeerConnection` in `Test.Cardano.Network.PeerSelection.MockEnvironment`:
-  - Now only creates a new connection if no inbound connection is found and `ConnectionMode` allows it.
-  - Added tracing for newly created connections.
-
 ### Non-Breaking
 
-- Added a new tracer: `TraceEnvNewConnCreated`.
 - Added a property test to verify that the node never connects to peers behind a firewall.

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

@@ -132,6 +132,8 @@ tests =
                                  prop_diffusion_target_active_public_iosimpor
     , nightlyTest $ testProperty "target established local"
                                  prop_diffusion_target_established_local_iosimpor
+    , nightlyTest $ testProperty "never connect to peers behind a firewall"
+                                 prop_diffusion_never_connect_peer_behind_firewall_iosimpor
     , nightlyTest $ testProperty "target active local"
                                  prop_diffusion_target_active_local_iosimpor
     , nightlyTest $ testProperty "target active root"
@@ -192,6 +194,8 @@ tests =
                    prop_diffusion_target_active_public_iosim
     , testProperty "target established local"
                    prop_diffusion_target_established_local_iosim
+    , testProperty "never connect to peers behind a firewall"
+                   prop_diffusion_never_connect_peer_behind_firewall_iosim
     , testProperty "unit reconnect"
                    prop_unit_reconnect
     , testProperty "target active local"
@@ -2847,6 +2851,96 @@ prop_diffusion_target_established_local_iosim
 prop_diffusion_target_established_local_iosim
   = testWithIOSim prop_diffusion_target_established_local long_trace
 
+-- | Avoid connecting to root peers marked as behind a firewall and without
+-- inbound connection.
+--
+prop_diffusion_never_connect_peer_behind_firewall
+  :: SimTrace Void
+  -> Int
+  -> Property
+prop_diffusion_never_connect_peer_behind_firewall ioSimTrace traceNumber =
+    let events :: [Events DiffusionTestTrace]
+        events = Trace.toList
+               . fmap ( Signal.eventsFromList
+                      . fmap (\(WithName _ (WithTime t b)) -> (t, b))
+                      )
+               . splitWithNameTrace
+               . fmap (\(WithTime t (WithName name b)) ->
+                         WithName name (WithTime t b))
+               . withTimeNameTraceEvents
+                  @DiffusionTestTrace
+                  @NtNAddr
+               . Trace.take traceNumber
+               $ ioSimTrace
+
+    in conjoin
+      $ (\ev ->
+        let evsList = eventsToList ev
+            lastTime = fst
+                     . last
+                     $ evsList
+         in classifySimulatedTime lastTime
+          $ classifyNumberOfEvents (length evsList)
+          $ verify_target_established_local ev
+        )
+      <$> events
+
+  where
+    verify_target_established_local :: Events DiffusionTestTrace
+                                    -> Property
+    verify_target_established_local events  =
+      let govLocalRootPeersSig
+            :: Signal (LocalRootPeers.LocalRootPeers PeerTrustable NtNAddr)
+          govLocalRootPeersSig =
+            selectDiffusionPeerSelectionState Governor.localRootPeers events
+
+          govUnreachablePeersSig :: Signal (Set NtNAddr)
+          govUnreachablePeersSig =
+            (\local ->
+               let
+                 isUnreachablePeer (LocalRootConfig {localRootBehindFirewall}) =
+                   localRootBehindFirewall
+                 unreachablePeers =
+                   Map.keysSet
+                     $ Map.filter isUnreachablePeer
+                     $ LocalRootPeers.toMap local
+               in
+                 unreachablePeers
+            ) <$> govLocalRootPeersSig
+
+          govInboundConnectionsSig :: Signal (Set NtNAddr)
+          govInboundConnectionsSig =
+              Signal.keyedLinger
+                180 -- 3 minutes
+                (Just . fromMaybe Set.empty)
+            . Signal.fromEvents
+            . Signal.selectEvents
+                (\case
+                  DiffusionConnectionManagerTrace
+                    -- initiated by remote
+                    (CM.TrConnectionNotFound Inbound peer) ->
+                      Just (Set.singleton peer)
+                  _other -> Nothing
+                )
+            $ events
+
+      in counterexample
+          ("\nSignal key: (local root peers, unreachables, inbounds") $
+        signalProperty 100 show
+          (\(_,unreachables,inbounds) -> unreachables `Set.disjoint` inbounds)
+          ((,,) <$> govLocalRootPeersSig
+                   <*> govUnreachablePeersSig
+                   <*> govInboundConnectionsSig)
+
+prop_diffusion_never_connect_peer_behind_firewall_iosimpor
+  :: AbsBearerInfo -> DiffusionScript -> Property
+prop_diffusion_never_connect_peer_behind_firewall_iosimpor
+  = testWithIOSimPOR prop_diffusion_never_connect_peer_behind_firewall short_trace
+
+prop_diffusion_never_connect_peer_behind_firewall_iosim
+  :: AbsBearerInfo -> DiffusionScript -> Property
+prop_diffusion_never_connect_peer_behind_firewall_iosim
+  = testWithIOSim prop_diffusion_never_connect_peer_behind_firewall long_trace
 
 -- | A variant of
 -- 'Test.Ouroboros.Network.PeerSelection.prop_governor_target_active_below'

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

@@ -154,8 +154,6 @@ tests =
                      prop_governor_target_active_local_below
       , testProperty "progresses towards active target (from above)"
                      prop_governor_target_active_local_above
-      , testProperty "never connect to peers behind a firewall"
-                     prop_governor_never_connect_peer_behind_firewall
       ]
 
     , testGroup "big ledger peers"
@@ -801,7 +799,6 @@ envEventCredits (TraceEnvSetLocalRoots  peers)  = LocalRootPeers.size peers
 envEventCredits (TraceEnvSetPublicRoots peers)  = PublicRootPeers.size Cardano.ExtraPeers.size peers
 envEventCredits  TraceEnvRequestPublicRootPeers = 0
 envEventCredits  TraceEnvRequestBigLedgerPeers  = 0
-envEventCredits  (TraceEnvNewConnCreated _)     = 0
 envEventCredits  TraceEnvPublicRootTTL          = 60
 envEventCredits  TraceEnvBigLedgerPeersTTL      = 60
 
@@ -3209,57 +3206,6 @@ prop_governor_target_established_above (MaxTime maxTime) env =
                      <*> govInProgressIneligibleSig
                      <*> demotionOpportunitiesIgnoredTooLong)
 
--- |  Avoid connecting to root peers marked as behind a firewall and without inbound connection.
-prop_governor_never_connect_peer_behind_firewall :: MaxTime -> GovernorMockEnvironment -> Property
-prop_governor_never_connect_peer_behind_firewall (MaxTime maxTime) env =
-    let events = Signal.eventsFromListUpToTime maxTime
-               . selectPeerSelectionTraceEvents
-                   @Cardano.ExtraState
-                   @PeerTrustable
-                   @(Cardano.ExtraPeers PeerAddr)
-                   @(Cardano.ExtraPeerSelectionSetsWithSizes PeerAddr)
-                   @Cardano.ExtraTrace
-               . runGovernorInMockEnvironment
-               $ env
-
-        govLocalRootPeersSig :: Signal (LocalRootPeers PeerTrustable PeerAddr)
-        govLocalRootPeersSig =
-          selectGovState Governor.localRootPeers
-                         (Cardano.ExtraState.empty (consensusMode env) (NumberOfBigLedgerPeers 0)) Cardano.ExtraPeers.empty
-                         events
-
-        govUnreachablePeersSig :: Signal (Set PeerAddr)
-        govUnreachablePeersSig =
-          (\local ->
-             let
-               isUnreachablePeer (LocalRootConfig {localRootBehindFirewall}) = localRootBehindFirewall
-
-               unreachablePeers =
-                 Map.keysSet
-                   $ Map.filter isUnreachablePeer
-                   $ LocalRootPeers.toMap local
-             in
-               unreachablePeers
-          ) <$> govLocalRootPeersSig
-
-        newConnectionSig :: Signal (Maybe PeerAddr)
-        newConnectionSig =
-            Signal.fromEvents
-          . Signal.selectEvents
-              (\case TraceEnvNewConnCreated addr -> Just $! addr
-                     _other                       -> Nothing)
-          . selectEnvEvents
-          $ events
-
-     in counterexample
-          "\nSignal key: (local root peers, unreachable local root peers, new connection)" $
-
-        signalProperty 100 show
-          (\(_,unreachablePeers,newConnection) -> maybe True (not . flip Set.member unreachablePeers) newConnection)
-          ((,,) <$> govLocalRootPeersSig
-                <*> govUnreachablePeersSig
-                <*> newConnectionSig)
-
 -- | Like 'prop_governor_target_established_above' but for big ledger peers.
 --
 prop_governor_target_established_big_ledger_peers_above
@@ -3613,7 +3559,7 @@ prop_governor_target_established_local (MaxTime maxTime) env =
         promotionOpportunitiesIgnoredTooLong :: Signal (Set PeerAddr)
         promotionOpportunitiesIgnoredTooLong =
           Signal.keyedTimeout
-            2 -- seconds  -- cabal run cardano-diffusion:cardano-diffusion-sim-tests -- --quickcheck-replay="(SMGen 13722084053961804625 14989040016076027617,42)" -p '/local root peers/&&/progresses towards established target/'
+            1 -- seconds
             id
             promotionOpportunities
 

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

@@ -48,7 +48,7 @@ import Data.IP (toIPv4w)
 
 import Control.Concurrent.Class.MonadSTM
 import Control.Concurrent.Class.MonadSTM.Strict qualified as StrictTVar
-import Control.Exception (throw, ErrorCall (..))
+import Control.Exception (throw)
 import Control.Monad (forM, when)
 import Control.Monad.Class.MonadAsync
 import Control.Monad.Class.MonadFork
@@ -331,7 +331,6 @@ data TraceMockEnv = TraceEnvAddPeers       !PeerGraph
                   | TraceEnvSetTargets     !PeerSelectionTargets
                   | TraceEnvPeersDemote    !AsyncDemotion !PeerAddr
                   | TraceEnvEstablishConn  !PeerAddr
-                  | TraceEnvNewConnCreated !PeerAddr
                   | TraceEnvActivatePeer   !PeerAddr
                   | TraceEnvDeactivatePeer !PeerAddr
                   | TraceEnvCloseConn      !PeerAddr
@@ -551,34 +550,20 @@ mockPeerSelectionActions' tracer
           threadDelay (interpretPeerShareTime time)
           traceWith tracer (TraceEnvPeerShareResult addr peeraddrs)
           return (PeerSharingResult peeraddrs)
+
     establishPeerConnection :: IsBigLedgerPeer -> DiffusionMode -> PeerAddr -> ConnectionMode -> m (PeerConn m)
-    establishPeerConnection _ _ peeraddr connMode = do
+    establishPeerConnection _ _ peeraddr _ = do
       --TODO: add support for variable delays and synchronous failure
       traceWith tracer (TraceEnvEstablishConn peeraddr)
       threadDelay 1
       let Just (_, peerSharingScript, connectScript) = Map.lookup peeraddr scripts
-      (conn@(PeerConn _ _ v), newConnCreated) <- atomically $ do
+      conn@(PeerConn _ _ v) <- atomically $ do
+        conn  <- newTVar PeerWarm
         conns <- readTVar connsVar
-        (conn, conns', newConnCreated) <- maybe
-          ( case connMode of
-              CreateNewIfNoInbound -> do
-                conn <- newTVar PeerWarm
-                pure (conn, conns, True)
-              RequireInbound -> do
-                throwSTM (ErrorCall "No inbound connection found.")
-          )
-          (\conn -> do
-              pure (conn, Map.insert peeraddr conn conns, False)
-          )
-          (Map.lookup peeraddr conns)
-
+        let !conns' = Map.insert peeraddr conn conns
         writeTVar connsVar conns'
         remotePeerSharing <- stepScriptSTM peerSharingScript
-        return (PeerConn peeraddr (peerSharingFlag <> remotePeerSharing) conn, newConnCreated)
-
-      when newConnCreated $
-        traceWith tracer (TraceEnvNewConnCreated peeraddr)
-
+        return (PeerConn peeraddr (peerSharingFlag <> remotePeerSharing) conn)
       _ <- async $
         -- monitoring loop which does asynchronous demotions. It will terminate
         -- as soon as either of the events: