From beccd2f84fab57368058a8ab01de2a47937e4444 Mon Sep 17 00:00:00 2001
From: Armando Santos <armando@well-typed.com>
Date: Fri, 29 Sep 2023 16:58:33 +0100
Subject: [PATCH] Fix NotReleasedConnections in Server2 tests

---
 ouroboros-network-framework/CHANGELOG.md      |  2 ++
 .../Test/Ouroboros/Network/Server2/Sim.hs     | 30 +++++++++----------
 2 files changed, 17 insertions(+), 15 deletions(-)

diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md
index a0af5ffbd79..206041061e8 100644
--- a/ouroboros-network-framework/CHANGELOG.md
+++ b/ouroboros-network-framework/CHANGELOG.md
@@ -20,6 +20,8 @@
 * Fixed a bug in `connection-manager` which could result in leaking
   a connection.
 
+* Fix Server2 [sim test](https://github.com/input-output-hk/ouroboros-network/issues/4607) by synchronizing connection/disconnection events.
+
 ## 0.9.0.0 -- 2023-08-21
 
 ### Breaking changes
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
index 39fe073fc86..6cf0c0e518d 100644
--- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs
+++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs
@@ -24,7 +24,7 @@ import           Control.Applicative (Alternative ((<|>)))
 import qualified Control.Concurrent.Class.MonadSTM as LazySTM
 import           Control.Concurrent.Class.MonadSTM.Strict
 import           Control.Exception (SomeAsyncException (..), SomeException (..))
-import           Control.Monad (replicateM, when)
+import           Control.Monad (replicateM)
 import           Control.Monad.Class.MonadAsync
 import           Control.Monad.Class.MonadFork
 import           Control.Monad.Class.MonadSay
@@ -770,8 +770,7 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer cmTracer
                           (mkNextRequests connVar)
                           timeLimitsHandshake
                           acceptedConnLimit
-                          ( \ connectionManager _ serverAsync -> do
-                            linkOnly (const True) serverAsync
+                          ( \ connectionManager _ _serverAsync -> do
                             connectionLoop SingInitiatorResponderMode localAddr cc connectionManager Map.empty connVar
                           )
                         -- `JobPool` does not catch any async exceptions, so we
@@ -837,12 +836,11 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer cmTracer
          -> StrictTVar m (Map.Map (ConnectionId peerAddr) (TemperatureBundle (StrictTQueue m [req])))
          -- ^ mini protocol queues
          -> m ()
-    connectionLoop muxMode localAddr cc cm connMap0 connVar = go True connMap0
+    connectionLoop muxMode localAddr cc cm connMap0 connVar = go connMap0
       where
-        go :: Bool -- if false do not run 'unregisterOutboundConnection'
-           -> Map.Map peerAddr (HandleWithExpandedCtx muxMode peerAddr DataFlowProtocolData ByteString m [resp] a) -- active connections
+        go :: Map.Map peerAddr (HandleWithExpandedCtx muxMode peerAddr DataFlowProtocolData ByteString m [resp] a) -- active connections
            -> m ()
-        go !unregister !connMap = atomically (readTQueue cc) >>= \ case
+        go !connMap = atomically (readTQueue cc) >>= \ case
           NewConnection remoteAddr -> do
             let mkQueue :: forall pt. SingProtocolTemperature pt
                         -> STM m (StrictTQueue m [req])
@@ -860,18 +858,20 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer cmTracer
                           $ requestOutboundConnection cm remoteAddr
             case connHandle of
               Left _ ->
-                go False connMap
+                go connMap
               Right (Connected _ _ h) -> do
                 qs <- atomically $ sequenceA $ makeBundle mkQueue
                 atomically $ modifyTVar connVar
                            $ Map.insert (connId remoteAddr) qs
-                go True (Map.insert remoteAddr h connMap)
+                go (Map.insert remoteAddr h connMap)
               Right Disconnected {} -> return ()
           Disconnect remoteAddr -> do
-            atomically $ modifyTVar connVar $ Map.delete (connId remoteAddr)
-            when unregister $
-              void (unregisterOutboundConnection cm remoteAddr)
-            go False (Map.delete remoteAddr connMap)
+            atomically $ do
+              m <- readTVar connVar
+              check (Map.member (connId remoteAddr) m)
+              writeTVar connVar (Map.delete (connId remoteAddr) m)
+            void (unregisterOutboundConnection cm remoteAddr)
+            go (Map.delete remoteAddr connMap)
           RunMiniProtocols remoteAddr reqs -> do
             atomically $ do
               mqs <- Map.lookup (connId remoteAddr) <$> readTVar connVar
@@ -908,8 +908,8 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer cmTracer
                   Left  {} -> do
                     atomically
                       $ modifyTVar connVar (Map.delete (connId remoteAddr))
-                    go unregister (Map.delete remoteAddr connMap)
-                  Right {} -> go unregister connMap
+                    go (Map.delete remoteAddr connMap)
+                  Right {} -> go connMap
           Shutdown -> return ()
           where
             connId remoteAddr = ConnectionId { localAddress  = localAddr