Never connect to peers behind a firewall property test

Author: the-headless-ghost

ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs

@@ -166,6 +166,8 @@ 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"
@@ -3233,6 +3235,64 @@ prop_governor_target_active_big_ledger_peers_above (MaxTime maxTime) env =
                  <*> demotionOpportunities
                  <*> 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@GovernorMockEnvironment{inboundPeers} =
+    let events = Signal.eventsFromListUpToTime maxTime
+               . selectPeerSelectionTraceEvents
+                   @Cardano.ExtraState
+                   @PeerTrustable
+                   @(Cardano.ExtraPeers PeerAddr)
+                   @(Cardano.ExtraPeerSelectionSetsWithSizes PeerAddr)
+               . 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 addr (LocalRootConfig {behindFirewall}) =
+                 behindFirewall && not (Set.member addr inboundPeers)
+
+               unreachablePeers =
+                 Map.keysSet
+                   $ Map.filterWithKey isUnreachablePeer
+                   $ LocalRootPeers.toMap local
+             in
+               unreachablePeers
+          ) <$> govLocalRootPeersSig
+
+        govPromotionSig :: Signal (Set PeerAddr)
+        govPromotionSig =
+            Signal.fromEventsWith Set.empty
+          . Signal.selectEvents
+              (\case TracePromoteColdPeers _ _ peers  -> Just $! peers
+                     _ -> Nothing
+              )
+          . selectGovEvents
+          $ events
+
+        unreachablePromotions :: Signal (Set PeerAddr)
+        unreachablePromotions =
+          Set.intersection
+            <$> govUnreachablePeersSig
+            <*> govPromotionSig
+
+     in counterexample
+          "\nSignal key: (local root peers, unreachable local root peers, promotions, unreachable promotions)" $
+
+        signalProperty 20 show
+          (\(_,_,_,promotions) -> Set.null promotions)
+          ((,,,) <$> govLocalRootPeersSig
+                 <*> govUnreachablePeersSig
+                 <*> govPromotionSig
+                 <*> unreachablePromotions)
 
 -- | A variant of 'prop_governor_target_established_below' but for the target
 -- that all local root peers should become established.