network-transport-quic: clean up the endpoint close process

cabal.project

@@ -9,5 +9,8 @@ allow-newer:
   cborg:base,
   serialise:base
 
+-- 2.1.3 is broken: https://github.com/kazu-yamamoto/crypton/issues/270
+constraints: crypton <2.1.3
+
 package distributed-process-tests
   flags: +tcp

packages/network-transport-quic/CHANGELOG.md

@@ -1,3 +1,6 @@
+2026-09-30  Laurent P. René de Cotret <laurent.decotret@outlook.com> 0.2.0
+
+* Cleaned up the endpoint closing process, which required adding a new configuration to `QUICTransportConfig`.
 
 2026-04-21  Laurent P. René de Cotret <laurent.decotret@outlook.com> 0.1.2
 

packages/network-transport-quic/README.md

@@ -31,6 +31,7 @@ main = do
                             , serviceName = "https" -- alternatively, some port number
                             , credentials = NonEmpty.singleton credential
                             , validateCredentials = True -- should be 'False' for self-signed certificate
+                            , closeEndPointTimeout = 1000000
                             }
             transport <- createTransport config
             ...

packages/network-transport-quic/bench/Bench.hs

@@ -59,12 +59,10 @@ quicConfig =
             Left errmsg -> throwIO $ userError errmsg
             Right credentials ->
               QUIC.createTransport
-                ( QUIC.QUICTransportConfig
-                    { hostName = "127.0.0.1"
-                    , serviceName = "0"
-                    , credentials = credentials :| []
+                ( (QUIC.defaultQUICTransportConfig "127.0.0.1" (credentials :| []))
+                    { QUIC.serviceName = "0"
                     , -- credentials are self-signed
-                      validateCredentials = False
+                      QUIC.validateCredentials = False
                     }
                 )
     }

packages/network-transport-quic/network-transport-quic.cabal

@@ -1,6 +1,6 @@
 cabal-version: 3.0
 Name:          network-transport-quic
-Version:       0.1.2
+Version:       0.2.0
 build-Type:    Simple
 License:       BSD-3-Clause
 License-file:  LICENSE

packages/network-transport-quic/src/Network/Transport/QUIC/Internal.hs

@@ -30,7 +30,7 @@ import Control.Concurrent.STM.TQueue
     writeTQueue,
   )
 import Control.Exception (Exception (displayException), IOException, bracket, throwIO, try)
-import Control.Monad (unless, when)
+import Control.Monad (forM_, unless, void, when)
 import Data.Bifunctor (Bifunctor (first))
 import Data.Binary qualified as Binary (decodeOrFail)
 import Data.ByteString (ByteString, fromStrict)
@@ -274,11 +274,12 @@ handleIncomingMessages ourEndPoint remoteEndPoint =
             -- handleIncomingMessages only runs on incoming remote endpoints, so if
             -- the state was still Valid there is exactly one logical connection to
             -- surface as closed.
-            wasValid <- modifyMVar (remoteEndPoint ^. remoteEndPointState) $ \case
-              RemoteEndPointValid _ -> pure (RemoteEndPointClosed, True)
-              other -> pure (other, False)
-            when wasValid $
+            mIsClosed <- modifyMVar (remoteEndPoint ^. remoteEndPointState) $ \case
+              RemoteEndPointValid (ValidRemoteEndPointState _ isClosed) -> pure (RemoteEndPointClosed, Just isClosed)
+              other -> pure (other, Nothing)
+            forM_ mIsClosed $ \isClosed -> do
               atomically $ writeTQueue ourQueue (ConnectionClosed connectionId)
+              void $ tryPutMVar isClosed ()
 
     handleMessage :: [ByteString] -> IO ()
     handleMessage payload =

packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICTransport.hs

@@ -71,8 +71,9 @@ import Control.Concurrent.Async (forConcurrently_)
 import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar, readMVar, tryPutMVar)
 import Control.Concurrent.STM.TQueue (TQueue, writeTQueue)
 import Control.Exception (bracketOnError)
-import Control.Monad (forM_)
+import Control.Monad (forM_, void, when)
 import Control.Monad.STM (atomically)
+import Data.Either (isRight)
 import Data.Function ((&))
 import Data.List.NonEmpty (NonEmpty)
 import Data.List.NonEmpty qualified as NE
@@ -94,6 +95,7 @@ import Network.Transport.QUIC.Internal.Messaging
     sendCloseEndPoint,
   )
 import Network.Transport.QUIC.Internal.QUICAddr (EndPointId, QUICAddr (..), encodeQUICAddr)
+import System.Timeout (timeout)
 
 {- The QUIC transport has three levels of statefullness:
 
@@ -113,6 +115,9 @@ Finally, each connection between endpoint has some state, needed to receive data
 -}
 
 -- | Represents the configuration used by the entire transport.
+--
+-- You should use the default values in `defaultQUICTransportConfig` 
+-- and override the fields you care about.
 data QUICTransportConfig = QUICTransportConfig
   { -- | Host name, which can be an IP address or a domain name.
     hostName :: HostName,
@@ -123,7 +128,13 @@ data QUICTransportConfig = QUICTransportConfig
     -- | Note that if your credentials is self-signed, you will have
     -- to turn off 'validateCredentials'. This should only be set to 'False'
     -- in tests, or in a private network.
-    validateCredentials :: Bool
+    validateCredentials :: Bool,
+    -- | How long, in microseconds, closing an endpoint waits for each peer
+    -- to acknowledge that it has processed the close of our outgoing
+    -- connections to it.
+    --
+    -- @since 0.2.0
+    closeEndPointTimeout :: Int
   }
   deriving (Eq, Show)
 
@@ -133,7 +144,8 @@ defaultQUICTransportConfig host creds =
     { hostName = host,
       serviceName = "443",
       credentials = creds,
-      validateCredentials = True
+      validateCredentials = True,
+      closeEndPointTimeout = 1000000
     }
 
 data QUICTransport = QUICTransport
@@ -306,23 +318,30 @@ closeLocalEndpoint quicTransport localEndPoint = do
 
   -- Close outgoing remote endpoints before incoming. The peer's handleIncomingMessages
   -- reader writes ConnectionClosed in response to our outgoing close; its listenForClose
-  -- writes ErrorEvent in response to our incoming close. Processing outgoing first gives
-  -- the peer's event queue the expected ConnectionClosed-before-ErrorEvent ordering.
+  -- writes ErrorEvent in response to our incoming close. 
+  -- 
+  -- Each of these is read from a separate QUIC connection, so some synchronization is required.
+  -- That gives the peer's event queue the expected ConnectionClosed-before-ErrorEvent ordering.
   forM_ mPreviousState $ \vst -> do
-    forConcurrently_ (vst ^. outgoingConnections) tryCloseRemoteStream
-    forConcurrently_ (vst ^. incomingConnections) tryCloseRemoteStream
+    forConcurrently_ (vst ^. outgoingConnections) (tryCloseRemoteStream Outgoing)
+    forConcurrently_ (vst ^. incomingConnections) (tryCloseRemoteStream Incoming)
   atomically $ writeTQueue (localEndPoint ^. localQueue) EndPointClosed
   where
-    tryCloseRemoteStream :: RemoteEndPoint -> IO ()
-    tryCloseRemoteStream remoteEndPoint = do
+    tryCloseRemoteStream :: Direction -> RemoteEndPoint -> IO ()
+    tryCloseRemoteStream direction remoteEndPoint = do
       mCleanup <- modifyMVar (remoteEndPoint ^. remoteEndPointState) $ \case
         RemoteEndPointInit -> pure (RemoteEndPointClosed, Nothing)
         RemoteEndPointClosed -> pure (RemoteEndPointClosed, Nothing)
         RemoteEndPointValid vst ->
           pure
             ( RemoteEndPointClosed,
               Just $ do
-                _ <- sendCloseEndPoint (vst ^. remoteStream)
+                sent <- sendCloseEndPoint (vst ^. remoteStream)
+                when (direction == Outgoing && isRight sent) $
+                  void $
+                    timeout
+                      (closeEndPointTimeout $ quicTransport ^. transportConfig)
+                      (readMVar (vst ^. remoteStreamIsClosed))
                 _ <- tryPutMVar (vst ^. remoteStreamIsClosed) ()
                 pure ()
             )

packages/network-transport-quic/test/Test/Network/Transport/QUIC.hs

@@ -33,18 +33,18 @@ tests =
       testCaseWithTimeout "connections" $ withQUICTransport $ flip Tests.testConnections 5,
       testCaseWithTimeout "closeOneConnection" $ withQUICTransport $ flip Tests.testCloseOneConnection 5,
       testCaseWithTimeout "closeOneDirection" $ withQUICTransport $ flip Tests.testCloseOneDirection 5,
-      flaky $ testCaseWithTimeout "closeReopen" $ withQUICTransport $ flip Tests.testCloseReopen 5,
+      testCaseWithTimeout "closeReopen" $ withQUICTransport $ flip Tests.testCloseReopen 5,
       -- This test is flaky specifically in Github Actions
       flaky $ testCaseWithTimeout "parallelConnects" $ withQUICTransport $ flip Tests.testParallelConnects 5,
       testCaseWithTimeout "selfSend" $ withQUICTransport Tests.testSelfSend,
-      flaky $ testCaseWithTimeout "closeTwice" $ withQUICTransport $ flip Tests.testCloseTwice 1,
+      testCaseWithTimeout "closeTwice" $ withQUICTransport $ flip Tests.testCloseTwice 1,
       testCaseWithTimeout "connectToSelf" $ withQUICTransport $ flip Tests.testConnectToSelf 5,
       testCaseWithTimeout "connectToSelfTwice" $ withQUICTransport $ flip Tests.testConnectToSelfTwice 5,
       testCaseWithTimeout "closeSelf" $ withQUICTransport (Tests.testCloseSelf . pure . Right),
-      flaky $ testCaseWithTimeout "closeEndPoint" $ withQUICTransport $ flip Tests.testCloseEndPoint 1,
-      flaky $ testCaseWithTimeout "closeTransport" $ Tests.testCloseTransport mkQUICTransport,
-      flaky $ testCaseWithTimeout "connectClosedEndPoint" $ withQUICTransport Tests.testConnectClosedEndPoint,
-      flaky testSendVeryLargeMessages
+      testCaseWithTimeout "closeEndPoint" $ withQUICTransport $ flip Tests.testCloseEndPoint 1,
+      testCaseWithTimeout "closeTransport" $ Tests.testCloseTransport mkQUICTransport,
+      testCaseWithTimeout "connectClosedEndPoint" $ withQUICTransport Tests.testConnectClosedEndPoint,
+      testSendVeryLargeMessages
     ]
 
 flaky :: TestTree -> TestTree
@@ -69,10 +69,8 @@ mkQUICTransport = do
       Right creds ->
         Right
           <$> QUIC.createTransport
-            ( QUICTransportConfig
-                { hostName = "127.0.0.1",
-                  serviceName = "0",
-                  credentials = creds :| [],
+            ( (QUIC.defaultQUICTransportConfig "127.0.0.1" (creds :| []))
+                { serviceName = "0",
                   -- credentials are self-signed
                   validateCredentials = False
                 }