From 5e159a4ba0a0ef56225235df60f48fcc12801850 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Laurent=20P=2E=20Ren=C3=A9=20de=20Cotret?= Date: Wed, 13 Aug 2025 08:54:13 -0400 Subject: [PATCH] Work-in-progress --- packages/network-transport-quic/LICENSE | 20 ++ .../network-transport-quic.cabal | 93 +++++ .../src/Network/Transport/QUIC.hs | 16 + .../src/Network/Transport/QUIC/Internal.hs | 320 ++++++++++++++++++ .../Network/Transport/QUIC/Internal/Client.hs | 49 +++ .../Transport/QUIC/Internal/Configuration.hs | 60 ++++ .../Transport/QUIC/Internal/EndpointState.hs | 49 +++ .../Transport/QUIC/Internal/Messaging.hs | 131 +++++++ .../Transport/QUIC/Internal/QUICAddr.hs | 80 +++++ .../Transport/QUIC/Internal/QUICTransport.hs | 153 +++++++++ .../Network/Transport/QUIC/Internal/Server.hs | 50 +++ .../Network/Transport/QUIC/Internal/TLS.hs | 13 + packages/network-transport-quic/test/Main.hs | 16 + .../test/Test/Network/Transport/QUIC.hs | 49 +++ .../Transport/QUIC/Internal/Messaging.hs | 50 +++ .../Transport/QUIC/Internal/QUICAddr.hs | 57 ++++ .../test/credentials/cert.crt | 22 ++ .../test/credentials/cert.key | 28 ++ .../src/Network/Transport/TCP.hs | 2 + 19 files changed, 1258 insertions(+) create mode 100644 packages/network-transport-quic/LICENSE create mode 100644 packages/network-transport-quic/network-transport-quic.cabal create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC.hs create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC/Internal.hs create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Client.hs create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Configuration.hs create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC/Internal/EndpointState.hs create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Messaging.hs create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICAddr.hs create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICTransport.hs create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Server.hs create mode 100644 packages/network-transport-quic/src/Network/Transport/QUIC/Internal/TLS.hs create mode 100644 packages/network-transport-quic/test/Main.hs create mode 100644 packages/network-transport-quic/test/Test/Network/Transport/QUIC.hs create mode 100644 packages/network-transport-quic/test/Test/Network/Transport/QUIC/Internal/Messaging.hs create mode 100644 packages/network-transport-quic/test/Test/Network/Transport/QUIC/Internal/QUICAddr.hs create mode 100644 packages/network-transport-quic/test/credentials/cert.crt create mode 100644 packages/network-transport-quic/test/credentials/cert.key diff --git a/packages/network-transport-quic/LICENSE b/packages/network-transport-quic/LICENSE new file mode 100644 index 00000000..dc884cc4 --- /dev/null +++ b/packages/network-transport-quic/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) Laurent P. René de Cotret + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/packages/network-transport-quic/network-transport-quic.cabal b/packages/network-transport-quic/network-transport-quic.cabal new file mode 100644 index 00000000..ed9ad432 --- /dev/null +++ b/packages/network-transport-quic/network-transport-quic.cabal @@ -0,0 +1,93 @@ +cabal-version: 3.0 +Name: network-transport-quic +Version: 0.1.0 +build-Type: Simple +License: BSD-3-Clause +License-file: LICENSE +Copyright: Laurent P. René de Cotret +Author: Laurent P. René de Cotret +maintainer: The Distributed Haskell team +Stability: experimental +Homepage: http://haskell-distributed.github.com +Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues +Synopsis: Networking layer for Cloud Haskell based on QUIC +Description: Networking layer for Cloud Haskell based on QUIC +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 GHC==9.12.1 +Category: Network +extra-doc-files: ChangeLog +extra-source-files: test/credentials/* + +source-repository head + Type: git + Location: https://github.com/haskell-distributed/distributed-process + SubDir: packages/network-transport-quic + +common common + ghc-options: + -- warnings + -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + -Wunused-packages + -- The -threaded option is /required/ to use the quic library + -threaded + +library + import: common + build-depends: attoparsec + , base >= 4.14 && < 5 + , binary >= 0.8 && < 0.10 + , bytestring >= 0.10 && < 0.13 + , containers + , ip + , microlens-platform ^>=0.4 + , network >= 3.1 && < 3.3 + , network-transport >= 0.5 && < 0.6 + , quic ^>=0.2 + , stm >=2.4 && <2.6 + , text >= 2.0 && <2.2 + , tls + , tls-session-manager + exposed-modules: Network.Transport.QUIC + Network.Transport.QUIC.Internal + other-modules: Network.Transport.QUIC.Internal.Configuration + Network.Transport.QUIC.Internal.Client + Network.Transport.QUIC.Internal.EndpointState + Network.Transport.QUIC.Internal.Messaging + Network.Transport.QUIC.Internal.QUICAddr + Network.Transport.QUIC.Internal.QUICTransport + Network.Transport.QUIC.Internal.Server + Network.Transport.QUIC.Internal.TLS + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + -- The -threaded option is /required/ to use the quic library + hs-source-dirs: src + +test-suite network-transport-quic-tests + import: common + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + main-is: Main.hs + other-modules: Test.Network.Transport.QUIC + Test.Network.Transport.QUIC.Internal.Messaging + Test.Network.Transport.QUIC.Internal.QUICAddr + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: base + , bytestring + , filepath + , hedgehog + , ip + , network + , network-transport + , network-transport-quic + , network-transport-tests + , tasty ^>=1.5 + , tasty-hedgehog + , tasty-hunit + , text \ No newline at end of file diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC.hs b/packages/network-transport-quic/src/Network/Transport/QUIC.hs new file mode 100644 index 00000000..2c4bcb80 --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC.hs @@ -0,0 +1,16 @@ +module Network.Transport.QUIC ( + createTransport, + QUICAddr (..), + + -- * Re-export to generate credentials + Credential, + credentialLoadX509, +) where + +import Network.Transport.QUIC.Internal ( + -- \* Re-export to generate credentials + Credential, + QUICAddr (..), + createTransport, + credentialLoadX509, + ) diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal.hs new file mode 100644 index 00000000..4f1633ca --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Transport.QUIC.Internal ( + createTransport, + QUICAddr (..), + encodeQUICAddr, + decodeQUICAddr, + + -- * Re-export to generate credentials + Credential, + credentialLoadX509, + + -- * Message encoding and decoding + decodeMessage, + MessageReceived (..), + encodeMessage, +) where + +import Control.Concurrent (killThread) +import Control.Concurrent.STM (atomically, newTQueueIO, readTVar, readTVarIO, stateTVar, throwSTM) +import Control.Concurrent.STM.TQueue ( + TQueue, + readTQueue, + writeTQueue, + ) +import Control.Concurrent.STM.TVar (modifyTVar') +import Control.Exception (Exception (displayException), IOException, catch, throwIO, try) +import Control.Monad (unless, when) +import Data.Binary qualified as Binary (decodeOrFail, encode) +import Data.Bits (shiftL, (.|.)) +import Data.ByteString (StrictByteString, fromStrict) +import Data.ByteString qualified as BS +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict qualified as Map +import Lens.Micro.Platform ((%~), (+~)) +import Network.QUIC qualified as QUIC +import Network.Socket (HostName, ServiceName) +import Network.TLS (Credential) +import Network.Transport ( + ConnectErrorCode (ConnectNotFound), + ConnectHints, + Connection (..), + ConnectionId, + EndPoint (..), + EndPointAddress, + Event (..), + EventErrorCode (EventConnectionLost), + NewEndPointErrorCode, + NewMulticastGroupErrorCode (NewMulticastGroupUnsupported), + Reliability (ReliableOrdered), + ResolveMulticastGroupErrorCode (ResolveMulticastGroupUnsupported), + Transport (..), + TransportError (..), + ) +import Network.Transport.QUIC.Internal.Client (forkClient) +import Network.Transport.QUIC.Internal.Configuration (credentialLoadX509) +import Network.Transport.QUIC.Internal.Messaging (MessageReceived (..), decodeMessage, encodeMessage, receiveMessage, recvAck, sendAck, sendMessage) +import Network.Transport.QUIC.Internal.QUICAddr (EndPointId, QUICAddr (..), decodeQUICAddr, encodeQUICAddr) +import Network.Transport.QUIC.Internal.QUICTransport ( + LocalEndPoint, + QUICStreamId, + QUICTransport, + RemoteEndPoint (RemoteEndPoint), + localAddress, + localConnections, + localEndPointId, + localEndPoints, + localQueue, + localState, + newLocalEndPoint, + newQUICTransport, + nextQUICStreamId, + transportState, + (^.), + ) +import Network.Transport.QUIC.Internal.Server (forkServer) + +{- | Create a new Transport based on the QUIC protocol. + +Only a single transport should be created per Haskell process +(threads can, and should, create their own endpoints though). +-} +createTransport :: + HostName -> + ServiceName -> + NonEmpty Credential -> + IO Transport +createTransport host port creds = do + -- TODO: resolve host and port + quicTransport <- newQUICTransport host port + + serverThread <- + forkServer + host + port + creds + throwIO + throwIO + (handleNewStream quicTransport) + + pure $ + Transport + { newEndPoint = newTQueueIO >>= newEndpoint quicTransport creds + , closeTransport = killThread serverThread + } + +{- | Handle a new incoming connection. + +This is the function which: + 1. First initiates a relationship between endpoints, called a /handshake/ + 2. then continuously reads from the stream to queue up events for the appropriate endpoint. +-} +handleNewStream :: QUICTransport -> QUIC.Stream -> IO () +handleNewStream quicTransport stream = do + unless + ( QUIC.isClientInitiatedBidirectional + (QUIC.streamId stream) + ) + (throwIO (userError "QUIC stream is not bidirectional")) + + -- HANDSHAKE + -- At this time, the handshake is very simple: + -- we read the first message, which must be addressed + -- correctly by EndPointId. This first message is expected + -- to contain the other side's EndPointAddress + -- + -- If the EndPointId does not exist, we terminate the connection. + receiveMessage stream >>= \case + Left errmsg -> throwIO (userError $ "(handleNewStream) Could not decode handshake message: " <> errmsg) + Right StreamClosed -> pure () -- The connection aborts before the handshake + Right (Message endpointId payload) -> do + case Binary.decodeOrFail (fromStrict payload) of + Left (_, _, errmsg) -> + throwIO (userError $ "(handleNewStream) remote endpoint address in handshake could not be decoded: " <> errmsg) + Right (_, _, remoteEndPointAddress) -> do + state <- readTVarIO (quicTransport ^. transportState) + ourEndPoint <- + maybe + ( throwIO + ( userError $ + "(handleNewStream) Unknown endpointId " <> show endpointId + ) + ) + pure + (Map.lookup endpointId (state ^. localEndPoints)) + + connId <- atomically $ do + localEndPointState <- readTVar (ourEndPoint ^. localState) + let knownRemoteEndpoints = localEndPointState ^. localConnections + + when (remoteEndPointAddress `Map.member` knownRemoteEndpoints) $ + throwSTM (userError "(handleNewStream) a connection already exists") + + streamId <- + stateTVar + (ourEndPoint ^. localState) + ( \st -> + ( st ^. nextQUICStreamId + , st + & localConnections %~ Map.insert remoteEndPointAddress (RemoteEndPoint remoteEndPointAddress) + & nextQUICStreamId +~ 1 + ) + ) + + let connectionId = makeConnectionId (ourEndPoint ^. localEndPointId) streamId + + writeTQueue + (ourEndPoint ^. localQueue) + ( ConnectionOpened + connectionId + ReliableOrdered + remoteEndPointAddress + ) + + pure connectionId + + -- Sending an ack is important, because otherwise + -- the client may start sending messages well before we + -- start being able to receive them + sendAck stream + + -- If we've reached this stage, the connection handhake succeeded + handleIncomingMessages ourEndPoint remoteEndPointAddress connId + where + handleIncomingMessages :: LocalEndPoint -> EndPointAddress -> ConnectionId -> IO () + handleIncomingMessages ourEndPoint remoteEndPointAddress connectionId = + go `catch` prematureExit + where + ourId = ourEndPoint ^. localEndPointId + ourQueue = ourEndPoint ^. localQueue + + go = + receiveMessage stream + >>= \case + Left errmsg -> (throwIO $ userError $ "(handleIncomingMessages) Failed with: " <> errmsg) + Right (Message eid bytes) -> handleMessage eid bytes >> go + Right StreamClosed -> + atomically $ do + modifyTVar' + (ourEndPoint ^. localState) + (\st -> st & localConnections %~ Map.delete remoteEndPointAddress) + + writeTQueue + (ourEndPoint ^. localQueue) + (ConnectionClosed connectionId) + where + handleMessage :: EndPointId -> StrictByteString -> IO () + handleMessage eid payload + | eid /= ourId = throwIO (userError "(handleMessage) Payload directed to the wrong EndPointId") + | otherwise = atomically (writeTQueue ourQueue (Received connectionId [payload])) + + prematureExit :: IOException -> IO () + prematureExit exc = + atomically + ( writeTQueue + ourQueue + ( ErrorEvent + ( TransportError + (EventConnectionLost remoteEndPointAddress) + (displayException exc) + ) + ) + ) + +newEndpoint :: + QUICTransport -> + NonEmpty Credential -> + TQueue Event -> + IO (Either (TransportError NewEndPointErrorCode) EndPoint) +newEndpoint quicTransport creds newLocalQueue = do + ourEndPoint <- newLocalEndPoint quicTransport newLocalQueue + try $ + pure $ + EndPoint + { receive = atomically (readTQueue (ourEndPoint ^. localQueue)) + , address = ourEndPoint ^. localAddress + , connect = newConnection ourEndPoint creds + , newMulticastGroup = + pure . Left $ + TransportError + NewMulticastGroupUnsupported + "Multicast not supported" + , resolveMulticastGroup = + pure + . Left + . const + ( TransportError + ResolveMulticastGroupUnsupported + "Multicast not supported" + ) + , closeEndPoint = undefined + } + +-- This connection ID is expected to be unique in the transport. +-- We do this by combining this endpoint's ID (unique among +-- the transport) and the stream ID. It's not clear how unique the +-- stream ID should be, however +makeConnectionId :: EndPointId -> QUICStreamId -> ConnectionId +makeConnectionId ourId streamId = + fromIntegral ourId `shiftL` 32 .|. fromIntegral streamId + +newConnection :: + LocalEndPoint -> + NonEmpty Credential -> + EndPointAddress -> + Reliability -> + ConnectHints -> + IO (Either (TransportError ConnectErrorCode) Connection) +newConnection ourEndPoint creds remoteEndPointAddress _reliability _connectHints = do + if ourEndPoint ^. localAddress == remoteEndPointAddress + then undefined -- self-connection + else case decodeQUICAddr remoteEndPointAddress of + Left errmsg -> + pure $ + Left $ + TransportError + ConnectNotFound + ("Could not decode QUIC address: " <> errmsg) + Right (QUICAddr remoteHostname remotePort remoteEndPointId) -> do + (_, outgoingQueue) <- + forkClient + remoteHostname + remotePort + creds + throwIO + ( \queue stream -> do + -- Handshake on connection creation, which simply involves + -- sending our address over + sendMessage + stream + remoteEndPointId + [ BS.toStrict $ + Binary.encode (ourEndPoint ^. localAddress) + ] + + -- Server acknowledgement that the handshake is complete + -- means that we cannot send messages until the server + -- is ready for them + recvAck stream + + let loop = + atomically (readTQueue queue) + >>= maybe + (pure ()) + ( \msg -> + sendMessage stream remoteEndPointId msg >> loop + ) + + loop + ) + + pure $ + Right $ + Connection + { send = fmap Right . atomically . writeTQueue outgoingQueue . Just + , close = atomically (writeTQueue outgoingQueue Nothing) + } \ No newline at end of file diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Client.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Client.hs new file mode 100644 index 00000000..ceb59855 --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Client.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Transport.QUIC.Internal.Client (forkClient) where + +import Control.Concurrent (ThreadId, forkIOWithUnmask) +import Control.Concurrent.STM (TQueue, newTQueueIO) +import Control.Exception (SomeException, catch, mask, mask_) +import Data.List.NonEmpty (NonEmpty) +import Network.QUIC qualified as QUIC +import Network.QUIC.Client qualified as QUIC.Client +import Network.Socket (HostName, ServiceName) +import Network.Transport.QUIC.Internal.Configuration (Credential, mkClientConfig) + +forkClient :: + HostName -> + ServiceName -> + NonEmpty Credential -> + -- | Error handler that runs whenever an exception is thrown inside + -- the thread that connected to a server + (SomeException -> IO ()) -> + -- | Client function + (TQueue e -> QUIC.Stream -> IO ()) -> + IO (ThreadId, TQueue e) +forkClient host port creds errorHandler clientFunction = do + -- TODO: what's the point of using 'getAddrInfo' and 'getNameInfo' + -- if we already have the hostname and servicename? + clientConfig <- mkClientConfig host port creds + + outgoingQueue <- newTQueueIO + + let runClient :: QUIC.Connection -> IO () + runClient conn = mask $ \restore -> do + QUIC.waitEstablished conn + stream <- QUIC.stream conn + + catch + (restore (clientFunction outgoingQueue stream)) + (\(_ :: SomeException) -> QUIC.closeStream stream) + + QUIC.closeStream stream + + tid <- mask_ $ + forkIOWithUnmask $ + \unmask -> + catch + (unmask $ QUIC.Client.run clientConfig (\conn -> catch (runClient conn) errorHandler)) + errorHandler + + pure (tid, outgoingQueue) \ No newline at end of file diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Configuration.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Configuration.hs new file mode 100644 index 00000000..3b5f5e7d --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Configuration.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Transport.QUIC.Internal.Configuration ( + mkClientConfig, + mkServerConfig, + + -- * Re-export to generate credentials + Credential, + TLS.credentialLoadX509, +) where + +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Network.QUIC.Client (ClientConfig (ccALPN, ccValidate), ccPortName, ccServerName, defaultClientConfig) +import Network.QUIC.Internal (ServerConfig (scALPN), ccCredentials) +import Network.QUIC.Server (ServerConfig (scAddresses, scCredentials, scSessionManager, scUse0RTT), defaultServerConfig) +import Network.Socket (HostName, ServiceName) +import Network.TLS (Credential, Credentials (Credentials)) +import Network.Transport.QUIC.Internal.TLS qualified as TLS + +mkClientConfig :: + HostName -> + ServiceName -> + NonEmpty Credential -> + IO ClientConfig +mkClientConfig host port creds = do + pure $ + defaultClientConfig + { ccServerName = host + , ccPortName = port + , ccALPN = \_version -> pure (Just ["perf"]) + , ccValidate = False + , ccCredentials = Credentials (NonEmpty.toList creds) + -- , ccWatchDog = True + -- , -- The following two parameters are for debugging. TODO: turn off by default + -- ccDebugLog = True + -- , ccKeyLog = putStrLn + } + +mkServerConfig :: + HostName -> + ServiceName -> + NonEmpty Credential -> + IO ServerConfig +mkServerConfig host port creds = do + tlsSessionManager <- TLS.sessionManager + + pure $ + defaultServerConfig + { scAddresses = [(read host, read port)] + , scSessionManager = tlsSessionManager + , scCredentials = Credentials (NonEmpty.toList creds) + , scALPN = Just $ \_version _protocols -> pure "perf" + , scUse0RTT = True + -- TODO: send heartbeats regularly + -- , scParameters = + -- (scParameters defaultServerConfig) + -- { maxIdleTimeout = Milliseconds 1000 + -- } + } \ No newline at end of file diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/EndpointState.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/EndpointState.hs new file mode 100644 index 00000000..dae5b202 --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/EndpointState.hs @@ -0,0 +1,49 @@ +module Network.Transport.QUIC.Internal.EndpointState ( + EndpointState, + newEndpointState, + registerStream, + deregisterStream, +) where + +import Control.Monad (void) +import Data.Function ((&)) +import Data.IORef (IORef, newIORef) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.IORef (atomicModifyIORef'_) +import Network.QUIC (Stream, streamId) +import Network.Transport (EndPointAddress) + +newtype EndpointState = EndpointState (IORef (Map EndPointAddress Stream)) + +-- \^ Mapping from destination address to stream. +-- A 'Stream' will have two keys since a stream is bidirectional. + +newEndpointState :: IO EndpointState +newEndpointState = EndpointState <$> newIORef mempty + +registerStream :: + EndpointState -> + EndPointAddress -> + EndPointAddress -> + Stream -> + IO () +registerStream (EndpointState strs) source dest stream = + void $ + atomicModifyIORef'_ + strs + ( \st -> + st + & Map.insert source stream + & Map.insert dest stream + ) + +deregisterStream :: EndpointState -> Stream -> IO () +deregisterStream (EndpointState strs) stream = + void $ + atomicModifyIORef'_ + strs + ( \st -> + let thisStreamId = streamId stream + in Map.filter ((/=) thisStreamId . streamId) st + ) \ No newline at end of file diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Messaging.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Messaging.hs new file mode 100644 index 00000000..f22982bd --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Messaging.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Transport.QUIC.Internal.Messaging ( + sendMessage, + receiveMessage, + MessageReceived (..), + + -- * Specialized messages + sendAck, + recvAck, + + -- * Re-exported for testing + encodeMessage, + decodeMessage, +) where + +import Control.Exception (catch, mask, throwIO) +import Control.Monad (unless) +import Data.Binary.Builder qualified as Builder +import Data.Bits (shiftL) +import Data.ByteString (StrictByteString, toStrict) +import Data.ByteString qualified as BS +import Data.ByteString.Builder qualified as Builder +import Data.Functor ((<&>)) +import Data.Word (Word32, Word8) +import GHC.Exception (Exception) +import Network.QUIC (Stream) +import Network.QUIC qualified as QUIC +import Network.Transport.QUIC.Internal.QUICAddr (EndPointId) +import System.Timeout (timeout) + +{- | Send a message to a remote endpoint ID + +This function is thread-safe; while the data is sending, asynchronous +exceptions are masked, to be rethrown after the data is sent. +-} +sendMessage :: + Stream -> + EndPointId -> + [StrictByteString] -> + IO () +sendMessage stream endpointId message = mask $ \restore -> + restore (QUIC.sendStreamMany stream (encodeMessage endpointId message)) + `catch` (\(ex :: QUIC.QUICException) -> throwIO ex) + +{- | Receive a message, including its local destination endpoint ID + +This function is thread-safe; while the data is being received, asynchronous +exceptions are masked, to be rethrown after the data is sent. +-} +receiveMessage :: + Stream -> + IO (Either String MessageReceived) +receiveMessage stream = mask $ \restore -> + restore (decodeMessage (QUIC.recvStream stream)) + `catch` (\(ex :: QUIC.QUICException) -> throwIO ex) + +{- | Encode a message. + +The encoding is composed of a header, and the payload. +The message header is composed of two 32-bit numbers: + The endpoint ID of the destination endpoint, padded to a 32-bit big endian number; + The length of the payload, again padded to a 32-bit big endian number +-} +encodeMessage :: + EndPointId -> + [StrictByteString] -> + [StrictByteString] +encodeMessage endpointId message + | endpointId < 0 = error "Negative EndPointId" + | otherwise = + [header] <> message + where + -- The message header is composed of two 32-bit numbers: + -- The endpoint ID of the destination endpoint; + -- The length of the payload + header = + toStrict $ + Builder.toLazyByteString $ + Builder.word32BE (fromIntegral endpointId) <> Builder.word32BE (fromIntegral (sum (BS.length <$> message))) + +decodeMessage :: (Int -> IO StrictByteString) -> IO (Either String MessageReceived) +decodeMessage getBytes = do + header <- getBytes 8 + if BS.null header + then pure $ Right StreamClosed + else case BS.unpack header of + [e1, e2, e3, e4, l1, l2, l3, l4] -> + let endpointId = fromIntegral $ w32BE e1 e2 e3 e4 + messageLength = w32BE l1 l2 l3 l4 + in getBytes (fromIntegral messageLength) <&> Right . Message endpointId + _ -> pure $ Left "Message header could not be decoded" + +data MessageReceived + = Message !EndPointId !StrictByteString + | StreamClosed + +-- | Build a 32-bit number in big-endian encoding from bytes +w32BE :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 +w32BE w1 w2 w3 w4 = + let nbitsInByte = 8 + in -- This is clunky AF + sum + [ fromIntegral w1 `shiftL` (3 * nbitsInByte) + , fromIntegral w2 `shiftL` (2 * nbitsInByte) + , fromIntegral w3 `shiftL` nbitsInByte + , fromIntegral w4 + ] + +newtype AckException = AckException String + deriving (Show, Eq) + +instance Exception AckException + +ackMessage :: StrictByteString +ackMessage = toStrict (Builder.toLazyByteString (Builder.word32BE 0)) + +sendAck :: Stream -> IO () +sendAck = + flip + QUIC.sendStream + ackMessage + +recvAck :: Stream -> IO () +recvAck stream = + -- TODO: make timeout configurable + timeout 500_000 (QUIC.recvStream stream (BS.length ackMessage)) + >>= maybe + (throwIO (AckException "Connection ack not received within acceptable timeframe")) + (\ack -> unless (ack == ackMessage) (throwIO (AckException "Unexpected new connection ack"))) \ No newline at end of file diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICAddr.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICAddr.hs new file mode 100644 index 00000000..43dafe4b --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICAddr.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Network.Transport.QUIC.Internal.QUICAddr ( + EndPointId (..), + QUICAddr (..), + encodeQUICAddr, + decodeQUICAddr, +) where + +import Data.Attoparsec.Text (Parser, endOfInput, parseOnly, ()) +import Data.Attoparsec.Text qualified as A +import Data.ByteString.Char8 qualified as BS8 +import Data.Text qualified as Text (unpack) +import Data.Text.Encoding (decodeUtf8Lenient) +import Data.Word (Word32) +import Net.IPv4 (IPv4) +import Net.IPv4 qualified as IPv4 +import Net.IPv6 (IPv6) +import Net.IPv6 qualified as IPv6 +import Network.Socket (HostName, ServiceName) +import Network.Transport (EndPointAddress (EndPointAddress)) + +{- | Represents the unique ID of an endpoint within a transport. + +This is used by endpoints to identify remote endpoints, even though +the remote endpoints are all backed by the same QUIC address. +-} +newtype EndPointId = EndPointId Word32 + deriving newtype (Eq, Show, Ord, Bounded, Enum, Real, Integral, Num) + +-- A QUICAddr represents the unique address an `endpoint` has, which involves +-- pointing to the transport (HostName, ServiceName) and then specific +-- endpoint spawned by that transport (EndpointId) +data QUICAddr = QUICAddr + { quicBindHost :: !HostName + , quicBindPort :: !ServiceName + , quicEndpointId :: !EndPointId + } + deriving (Eq, Ord, Show) + +-- | Encode a 'QUICAddr' to 'EndPointAddress' +encodeQUICAddr :: QUICAddr -> EndPointAddress +encodeQUICAddr (QUICAddr host port ix) = + EndPointAddress + (BS8.pack $ host <> ":" <> port <> ":" <> show ix) + +-- | Decode a 'QUICAddr' from an 'EndPointAddress' +decodeQUICAddr :: EndPointAddress -> Either String QUICAddr +decodeQUICAddr (EndPointAddress bytes) = + parseOnly (parser <* endOfInput) (decodeUtf8Lenient bytes) + where + parser = + QUICAddr + <$> (parseHostName <* A.char ':') + <*> (parseServiceName <* A.char ':') + <*> A.decimal + + parseHostName :: Parser HostName + parseHostName = + renderHostNameChoice + <$> A.choice + [ IPV6 <$> IPv6.parser "IPv6" + , IPV4 <$> IPv4.parser "IPv4" + , (Named . Text.unpack <$> A.takeTill (== ':')) "Named host" + ] + "Host name" + + parseServiceName :: Parser ServiceName + parseServiceName = Text.unpack <$> A.takeTill (== ':') "Service name" + +data HostNameChoice + = IPV4 IPv4 + | IPV6 IPv6 + | Named HostName + +renderHostNameChoice :: HostNameChoice -> HostName +renderHostNameChoice (IPV4 ipv4) = IPv4.encodeString ipv4 +renderHostNameChoice (IPV6 ipv6) = Text.unpack $ IPv6.encode ipv6 +renderHostNameChoice (Named hostName) = hostName \ No newline at end of file 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 new file mode 100644 index 00000000..728950e4 --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICTransport.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Transport.QUIC.Internal.QUICTransport ( + -- * QUICTransport + QUICTransport, + newQUICTransport, + transportHost, + transportPort, + transportState, + + -- * TransportState + TransportState, + localEndPoints, + nextEndPointId, + + -- * LocalEndPoint + LocalEndPoint, + newLocalEndPoint, + localAddress, + localEndPointId, + localState, + localQueue, + + -- * LocalEndPointState + LocalEndPointState, + localConnections, + nextQUICStreamId, + + -- ** QUICStreamId + QUICStreamId, + + -- * RemoteEndPoint + RemoteEndPoint (RemoteEndPoint), + remoteAddress, + + -- * Re-exports + (^.), +) where + +import Control.Concurrent.STM (TVar, modifyTVar', newTVar, newTVarIO, readTVar) +import Control.Concurrent.STM.TQueue (TQueue) +import Control.Monad (when) +import Control.Monad.STM (atomically, retry) +import Data.Function ((&)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Word (Word32) +import Lens.Micro.Platform (makeLenses, view, (%~), (+~), (^.)) +import Network.Socket (HostName, ServiceName) +import Network.Transport (EndPointAddress, Event) +import Network.Transport.QUIC.Internal.QUICAddr (EndPointId, QUICAddr (..), encodeQUICAddr) + +{- The QUIC transport has three levels of statefullness: + +1. The transport itself + +The transport contains state required to create new endpoints, and close them. This includes, +for example, a container of existing endpoints. + +2. Endpoints + +An endpoint has some state regarding the connections it has. An endpoint may have zero or more +connection, and must have state to be able to create new connections, and close existing ones. + +3. Connections + +Finally, each connection between endpoint has some state, needed to receive data. +-} + +data QUICTransport = QUICTransport + { _transportHost :: HostName + , _transportPort :: ServiceName + , _transportState :: TVar TransportState + } + +data TransportState = TransportState + { _localEndPoints :: !(Map EndPointId LocalEndPoint) + , _nextEndPointId :: !EndPointId + } + +-- | Create a new QUICTransport +newQUICTransport :: HostName -> ServiceName -> IO QUICTransport +newQUICTransport host port = + QUICTransport + host + port + <$> newTVarIO (TransportState mempty 1) + +data LocalEndPoint = LocalEndPoint + { _localAddress :: !EndPointAddress + , _localEndPointId :: !EndPointId + , _localState :: !(TVar LocalEndPointState) + , _localQueue :: !(TQueue Event) + -- ^ Queue used to receive events + } + +{- | A QUICSteamId uniquely identifies a QUIC stream within the context of an endpoint. + +NOTE: I tried to use the `StreamId` type from the `quic` library, but it was +clearly not unique per stream. I don't understand if this was intentional or not. +-} +newtype QUICStreamId = QUICStreamId Word32 + deriving newtype (Eq, Show, Ord, Bounded, Enum, Real, Integral, Num) + +data LocalEndPointState = LocalEndPointState + { _localConnections :: Map EndPointAddress RemoteEndPoint + , _nextQUICStreamId :: QUICStreamId + } + +newtype RemoteEndPoint = RemoteEndPoint + { _remoteAddress :: EndPointAddress + } + +makeLenses ''QUICTransport +makeLenses ''TransportState +makeLenses ''LocalEndPoint +makeLenses ''LocalEndPointState +makeLenses ''RemoteEndPoint + +newLocalEndPoint :: QUICTransport -> TQueue Event -> IO LocalEndPoint +newLocalEndPoint quicTransport newLocalQueue = atomically $ do + state <- readTVar (quicTransport ^. transportState) + let newEndPointId = state ^. nextEndPointId + existingEndPoints = state ^. localEndPoints + + newLocalState <- newTVar (LocalEndPointState mempty 0) + let endpoint = + LocalEndPoint + { _localAddress = + encodeQUICAddr + ( QUICAddr + (quicTransport ^. transportHost) + (quicTransport ^. transportPort) + newEndPointId + ) + , _localEndPointId = newEndPointId + , _localState = newLocalState + , _localQueue = newLocalQueue + } + highestExistingEndPointId = maybe (newEndPointId - 1) (view localEndPointId . fst) (Map.maxView existingEndPoints) + when (highestExistingEndPointId >= newEndPointId) retry + + -- I'm not sure how to resolve the race condition, whereby we could insert + -- `newEndPointId` from two separate threads, + modifyTVar' + (quicTransport ^. transportState) + ( \st -> + (st & localEndPoints %~ Map.insert newEndPointId endpoint) + & nextEndPointId +~ 1 + ) + pure endpoint diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Server.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Server.hs new file mode 100644 index 00000000..84c4716f --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Server.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Transport.QUIC.Internal.Server (forkServer) where + +import Control.Concurrent (ThreadId, forkIOWithUnmask) +import Control.Exception (SomeException, catch, mask, mask_) +import Data.List.NonEmpty (NonEmpty) +import Network.QUIC qualified as QUIC +import Network.QUIC.Server qualified as QUIC.Server +import Network.Socket (HostName, ServiceName) +import Network.Transport.QUIC.Internal.Configuration (Credential, mkServerConfig) + +forkServer :: + HostName -> + ServiceName -> + NonEmpty Credential -> + -- | Error handler that runs whenever an exception is thrown inside + -- the thread that accepted an incoming connection + (SomeException -> IO ()) -> + -- | Termination handler that runs if the server thread catches an exception + (SomeException -> IO ()) -> + -- | Request handler + (QUIC.Stream -> IO ()) -> + IO ThreadId +forkServer host port creds errorHandler terminationHandler requestHandler = do + -- TODO: what's the point of using 'getAddrInfo' and 'getNameInfo' + -- if we already have the hostname and servicename? + serverConfig <- mkServerConfig host port creds + + let acceptConnection :: QUIC.Connection -> IO () + acceptConnection conn = mask $ \restore -> do + QUIC.waitEstablished conn + stream <- QUIC.acceptStream conn + + catch + (restore (requestHandler stream)) + (\exc -> QUIC.closeStream stream >> errorHandler exc) + + -- We have to make sure that the exception handler is + -- installed /before/ any asynchronous exception occurs. So we mask_, then + -- forkIOWithUnmask (the child thread inherits the masked state from the parent), then + -- unmask only inside the catch. + -- + -- See the documentation for `forkIOWithUnmask`. + mask_ $ + forkIOWithUnmask $ + \unmask -> + catch + (unmask $ QUIC.Server.run serverConfig (\conn -> catch (acceptConnection conn) errorHandler)) + terminationHandler diff --git a/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/TLS.hs b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/TLS.hs new file mode 100644 index 00000000..4ab78014 --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/TLS.hs @@ -0,0 +1,13 @@ +module Network.Transport.QUIC.Internal.TLS ( + -- * TLS session manager + sessionManager, + + -- * Loading TLS credentials + credentialLoadX509, +) where + +import Network.TLS (SessionManager, credentialLoadX509) +import Network.TLS.SessionManager (defaultConfig, newSessionManager) + +sessionManager :: IO SessionManager +sessionManager = newSessionManager defaultConfig \ No newline at end of file diff --git a/packages/network-transport-quic/test/Main.hs b/packages/network-transport-quic/test/Main.hs new file mode 100644 index 00000000..93770ac9 --- /dev/null +++ b/packages/network-transport-quic/test/Main.hs @@ -0,0 +1,16 @@ +module Main (main) where + +import Test.Network.Transport.QUIC qualified (tests) +import Test.Network.Transport.QUIC.Internal.QUICAddr qualified (tests) +import Test.Network.Transport.QUIC.Internal.Messaging qualified (tests) +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain $ + testGroup + "network-transport-quic" + [ Test.Network.Transport.QUIC.Internal.Messaging.tests + , Test.Network.Transport.QUIC.Internal.QUICAddr.tests + , Test.Network.Transport.QUIC.tests + ] diff --git a/packages/network-transport-quic/test/Test/Network/Transport/QUIC.hs b/packages/network-transport-quic/test/Test/Network/Transport/QUIC.hs new file mode 100644 index 00000000..a222054c --- /dev/null +++ b/packages/network-transport-quic/test/Test/Network/Transport/QUIC.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Network.Transport.QUIC (tests) where + +import Control.Exception (bracket) +import Data.List.NonEmpty qualified as NonEmpty +import Network.Transport (Transport (closeTransport)) +import Network.Transport.QUIC qualified as QUIC +import Network.Transport.Tests qualified as Tests +import System.FilePath (()) +import System.Timeout (timeout) +import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "Network.Transport.QUIC" + [ testCaseWithTimeout "ping-pong" $ withQUICTransport $ flip Tests.testPingPong 5 + , testCaseWithTimeout "endpoints" $ withQUICTransport $ flip Tests.testEndPoints 2 + ] + +-- | Ensure that a test does not run for too long +testCaseWithTimeout :: TestName -> Assertion -> TestTree +testCaseWithTimeout name assertion = + testCase name $ + timeout 10_000_000 assertion + >>= maybe (assertFailure "Test timed out") pure + +-- event2 <- NT.receive endpoint2 + +-- print event2 + +withQUICTransport :: (Transport -> IO a) -> IO a +withQUICTransport = + bracket + ( QUIC.credentialLoadX509 + -- Generate a self-signed x509v3 certificate using this nifty tool: + -- https://certificatetools.com/ + ("test" "credentials" "cert.crt") + ("test" "credentials" "cert.key") + >>= either assertFailure pure + >>= QUIC.createTransport + "127.0.0.1" + "42065" + . NonEmpty.singleton + ) + closeTransport diff --git a/packages/network-transport-quic/test/Test/Network/Transport/QUIC/Internal/Messaging.hs b/packages/network-transport-quic/test/Test/Network/Transport/QUIC/Internal/Messaging.hs new file mode 100644 index 00000000..b41fda68 --- /dev/null +++ b/packages/network-transport-quic/test/Test/Network/Transport/QUIC/Internal/Messaging.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Network.Transport.QUIC.Internal.Messaging (tests) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.ByteString (StrictByteString) +import Data.ByteString qualified as BS +import Data.IORef (atomicModifyIORef, newIORef) +import Hedgehog (forAll, property, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Network.Transport.QUIC.Internal (MessageReceived (..), decodeMessage, encodeMessage) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +tests :: TestTree +tests = + testGroup + "Messaging" + [testMessageEncodingAndDecoding] + +testMessageEncodingAndDecoding :: TestTree +testMessageEncodingAndDecoding = testProperty "Encoded messages can be decoded" $ property $ do + -- The endpoint ID and message length are encoded and decoded the same way, to/from + -- a Word32. + -- Since we don't want to generate insanely long messages in this test, we exercise the + -- encoding/decoding of the endpoint ID by generating insanely large endpoint IDs + endpointId <- fmap fromIntegral <$> forAll $ Gen.word32 Range.constantBounded + + message <- forAll (Gen.list (Range.linear 0 3) (Gen.bytes (Range.linear 0 2048))) + let encoded = mconcat $ encodeMessage endpointId message + + getBytes <- liftIO $ messageDecoder encoded + + liftIO (decodeMessage getBytes) >>= \case + Left errmsg -> fail errmsg + Right StreamClosed -> fail "stream closed" + Right (Message eid bytes) -> (endpointId, mconcat message) === (eid, bytes) + +messageDecoder :: StrictByteString -> IO (Int -> IO StrictByteString) +messageDecoder allBytes = do + ref <- newIORef allBytes + pure + ( \nbytes -> do + atomicModifyIORef + ref + ( \remainingBytes -> + (BS.drop nbytes remainingBytes, BS.take nbytes remainingBytes) + ) + ) \ No newline at end of file diff --git a/packages/network-transport-quic/test/Test/Network/Transport/QUIC/Internal/QUICAddr.hs b/packages/network-transport-quic/test/Test/Network/Transport/QUIC/Internal/QUICAddr.hs new file mode 100644 index 00000000..2d309451 --- /dev/null +++ b/packages/network-transport-quic/test/Test/Network/Transport/QUIC/Internal/QUICAddr.hs @@ -0,0 +1,57 @@ +module Test.Network.Transport.QUIC.Internal.QUICAddr (tests) where + +import Data.Text qualified as Text (unpack) +import Hedgehog (Gen, forAll, property, tripping) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Net.IPv4 qualified as IPv4 +import Net.IPv6 qualified as IPv6 +import Network.Socket (HostName, ServiceName) +import Network.Transport.QUIC.Internal (QUICAddr (QUICAddr), decodeQUICAddr, encodeQUICAddr) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +tests :: TestTree +tests = + testGroup + "QUICAddr" + [testQUICAddrToEndpointAddress] + +testQUICAddrToEndpointAddress :: TestTree +testQUICAddrToEndpointAddress = testProperty "De/serialization of 'QUICAddr'" $ property $ do + addr <- forAll $ QUICAddr <$> genHostName <*> genServiceName <*> Gen.integral (Range.linear 1 10) + + tripping addr encodeQUICAddr decodeQUICAddr + +genHostName :: Gen HostName +genHostName = Gen.choice [genIPV4, genIPV6, genNamed] + where + genIPV4 :: Gen HostName + genIPV4 = + let fragment = Gen.word8 Range.constantBounded + in IPv4.encodeString <$> (IPv4.ipv4 <$> fragment <*> fragment <*> fragment <*> fragment) + + genIPV6 :: Gen HostName + genIPV6 = + let fragment = Gen.word16 Range.constantBounded + in Text.unpack . IPv6.encode + <$> ( IPv6.ipv6 + <$> fragment + <*> fragment + <*> fragment + <*> fragment + <*> fragment + <*> fragment + <*> fragment + <*> fragment + ) + + genNamed :: Gen HostName + genNamed = + liftA2 + (\domain extension -> domain <> "." <> extension) + (Gen.element ["google", "amazon", "aol"]) + (Gen.element ["ca", "com", "fr", "co.uk/some-route"]) + +genServiceName :: Gen ServiceName +genServiceName = show <$> Gen.word16 Range.constantBounded -- port number from 0 to 2^16 diff --git a/packages/network-transport-quic/test/credentials/cert.crt b/packages/network-transport-quic/test/credentials/cert.crt new file mode 100644 index 00000000..cec430e3 --- /dev/null +++ b/packages/network-transport-quic/test/credentials/cert.crt @@ -0,0 +1,22 @@ +-----BEGIN CERTIFICATE----- +MIIDoTCCAomgAwIBAgIUVp3lTRQWZSOwolWHNaghO6gR68owDQYJKoZIhvcNAQEL +BQAwRTESMBAGA1UEAwwJMTI3LjAuMC4xMQswCQYDVQQGEwJDQTEPMA0GA1UECAwG +UXVlYmVjMREwDwYDVQQHDAhNb250cmVhbDAgFw0yNTA4MTgwMDU1MDRaGA8yMTI1 +MDcyNTAwNTUwNFowRTESMBAGA1UEAwwJMTI3LjAuMC4xMQswCQYDVQQGEwJDQTEP +MA0GA1UECAwGUXVlYmVjMREwDwYDVQQHDAhNb250cmVhbDCCASIwDQYJKoZIhvcN +AQEBBQADggEPADCCAQoCggEBAORALZlg9Qmu+A2HT4MUjF1iGUdWF6tlRgF6+zLZ +uvuSM+eR0yH+EJZB2xqanzkXHVAkAnHPWRZ2HWqTS7TLOMyRdPEkiCg+WmW2f0t0 +hNCjZVMviahQgOwHkbTZbfsUHTv65cEk4XCgvQXFteMC+Q3lCeXWGoeMOt7AZ3ld +vf7jgmPTQXOQFhqa9q5Qcxn+b1+2NBgQXqEQTVARBLPbCB4M0SKLZ4fWK4VHZsbe +k8fUJBGgz/gTDNNClUiVBhBiv/9uvunZRpU1QBN5tZYXAPc0hX608L33R+LFsoDM +cO5+j+XIjvxWNk94cmM/cb4PLlZBeNBlXxWxY1lKAxjja58CAwEAAaOBhjCBgzAd +BgNVHQ4EFgQUGj/6Vt/0fjbTGBHPZNRIxJywRnkwHwYDVR0jBBgwFoAUGj/6Vt/0 +fjbTGBHPZNRIxJywRnkwDgYDVR0PAQH/BAQDAgWgMCAGA1UdJQEB/wQWMBQGCCsG +AQUFBwMBBggrBgEFBQcDAjAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUA +A4IBAQA+AuoFBODpWaWrVSjdGZPHP4DtlhB9jDy0WmUBJ8BxeB8SooJoyTsBXVhq +7ACKp11rxJPk9Tv9JOsRrWi+YLzgs+QsKpUKb6RK5nszz17K1md8BavGzE4n/e0F +tzYvWAeyIazHW551GMB1MkpSVcsJNqe91z35qmykmwIo8h+BgqTFzUFiln6bLnqP +KxrWKdlVh2BGEVbH5APClQii0bX1qEn0A8CkAMbldC1GNFbfhyxk1v+8CVK1M6Nx +BrTe15/CVTw/ceCfFZra4DinsflyCP+CcitGOUhWKgrUSiyN8xtr+Wopq4+ntm/Z +ku6j3frrSJnT9A+nZyyGvZlSPrxf +-----END CERTIFICATE----- diff --git a/packages/network-transport-quic/test/credentials/cert.key b/packages/network-transport-quic/test/credentials/cert.key new file mode 100644 index 00000000..17962456 --- /dev/null +++ b/packages/network-transport-quic/test/credentials/cert.key @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQDkQC2ZYPUJrvgN +h0+DFIxdYhlHVherZUYBevsy2br7kjPnkdMh/hCWQdsamp85Fx1QJAJxz1kWdh1q +k0u0yzjMkXTxJIgoPlpltn9LdITQo2VTL4moUIDsB5G02W37FB07+uXBJOFwoL0F +xbXjAvkN5Qnl1hqHjDrewGd5Xb3+44Jj00FzkBYamvauUHMZ/m9ftjQYEF6hEE1Q +EQSz2wgeDNEii2eH1iuFR2bG3pPH1CQRoM/4EwzTQpVIlQYQYr//br7p2UaVNUAT +ebWWFwD3NIV+tPC990fixbKAzHDufo/lyI78VjZPeHJjP3G+Dy5WQXjQZV8VsWNZ +SgMY42ufAgMBAAECggEAGfwodM6x9tFBkiC2b6DWPgdeA14Mwcl8x8xdbrOU8vD5 +EcLrO3J2JvUGYaf6uoAkKSyATr6hUMpPnQN52fJM3BUvMAjNq2810WCOa2OvfyUq +8uZ1kIDhvH08HE+okq3+igaNQ4jUVYMnIdIZW+fJvMg3cUAHsyjGxvc2kH2YlLzQ +3zxEFacnTb2K/Sxa/rFC7O3r2M6casTVsqfLyeShnSLEwLLk8tzCZZc6Sap9rVgh +CIcUhZFGxLYWMBJwRs68rmgT7rvQvh8NxzDMGM9Z/AQzeeHAvjAkb4gZBu+W69vD +CYjMi3cchdG/2ouYqijdv9DcqRDfz6BDwf8fT96dyQKBgQD0rGreqY7E8Wnt3EjF +TYwi6Hj7r6gMw3kdIIJ49st2lTvOmeZpvJX7DOh43NNidx9q2Ai1XCCEDQlpPS7i +UnqOLwX0gGYZjYkI8QSdNbJ9T4wepfSeox7dte/xnglEkfipHV3tLqhurgw+wvGW +52hBB6DVSumzjcG/hrvkDth31QKBgQDu0SMH5mg4L4KaT9+qZm3IW+Xey3vwPFES +w4bGsmAddzxXRIw6+ut2+AX/WSccUnZmgtiKKzS1yrBXGa98dqzjGRcDnbchkm+6 +Ka1s3ZSx7cjgya43jLIZ9ycwva8+OPPfzrOB6zLgIauwi5B7JsB1Qt81AXeo5/jb +S64FRXkjowKBgChebj+QoEK0RjL9nnAXTGDSFGwKXmLEua3pmD1XEtjc5IJA+DhH +6kMCrTSL0sCzQNbDECTEL4U6FWxssNicnSXqckQWD0J2DL8R7R33JxzvzAGehg7K +gSQ5iX5HAeZzYyCb/MxOX3Hre4+7YFrykUvxc0Ld2lNKt0XfeA63uFWFAoGAOMfk +ylYP5Xv2U3Y2Oa+M3pxq9SPwXdgZdpqiis+SZq8Y267ioItUPL8PvfyWffdlS05E +6eUH7Uk50Bu9S5xz0rL+c8+l4QeOJPcP0tiEKCHfJwMMtwxutBm9aatP5T1pToc4 +yuT+/adDyQAF5CH8lGTH6TRmHPS6iHlf8MTp3n0CgYEAwUWjiimBoPQV3X2mHYp5 +yXBKGrsEItOmZUKYpl9UGVdGHHuZqzKi5ckOUK+vfd2uH9toUBMFK5aBM3VmFWPb +3IpTrYe/Zu545dZszESjpl9JeiiSOVvPllCh0BrOAK1TwRapWUTsS8ut5pt5zLuo +VbKNvUzMHtq6vp511AD0zCY= +-----END PRIVATE KEY----- diff --git a/packages/network-transport-tcp/src/Network/Transport/TCP.hs b/packages/network-transport-tcp/src/Network/Transport/TCP.hs index bebfbd04..630269f7 100644 --- a/packages/network-transport-tcp/src/Network/Transport/TCP.hs +++ b/packages/network-transport-tcp/src/Network/Transport/TCP.hs @@ -15,6 +15,8 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use lambda-case" #-} module Network.Transport.TCP ( -- * Main API