diff --git a/cabal.project b/cabal.project index 8a019aad..e8510d48 100644 --- a/cabal.project +++ b/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 diff --git a/packages/network-transport-quic/CHANGELOG.md b/packages/network-transport-quic/CHANGELOG.md index d4e96dc1..b58e1bc8 100644 --- a/packages/network-transport-quic/CHANGELOG.md +++ b/packages/network-transport-quic/CHANGELOG.md @@ -1,3 +1,6 @@ +2026-09-30 Laurent P. René de Cotret 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 0.1.2 diff --git a/packages/network-transport-quic/README.md b/packages/network-transport-quic/README.md index dd4d03ba..93a8b18e 100644 --- a/packages/network-transport-quic/README.md +++ b/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 ... diff --git a/packages/network-transport-quic/bench/Bench.hs b/packages/network-transport-quic/bench/Bench.hs index 53e10d92..b8b6b4fe 100644 --- a/packages/network-transport-quic/bench/Bench.hs +++ b/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 } ) } diff --git a/packages/network-transport-quic/network-transport-quic.cabal b/packages/network-transport-quic/network-transport-quic.cabal index 883dec8d..d47a0a0f 100644 --- a/packages/network-transport-quic/network-transport-quic.cabal +++ b/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 diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal.hs index 76bd5cbd..97102624 100644 --- a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal.hs +++ b/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 = diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICTransport.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICTransport.hs index 1a3376bc..eab153d2 100644 --- a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICTransport.hs +++ b/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,15 +318,17 @@ 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) @@ -322,7 +336,12 @@ closeLocalEndpoint quicTransport localEndPoint = do 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 () ) diff --git a/packages/network-transport-quic/test/Test/Network/Transport/QUIC.hs b/packages/network-transport-quic/test/Test/Network/Transport/QUIC.hs index b20ad1c8..3b89009e 100644 --- a/packages/network-transport-quic/test/Test/Network/Transport/QUIC.hs +++ b/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 }