From bb03e5aefa646a7ea153cb1d8cf6e73e516bd338 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 | 97 ++++ .../src/Network/Transport/QUIC.hs | 16 + .../src/Network/Transport/QUIC/Internal.hs | 463 ++++++++++++++++++ .../Network/Transport/QUIC/Internal/Client.hs | 93 ++++ .../Transport/QUIC/Internal/Configuration.hs | 56 +++ .../Transport/QUIC/Internal/Messaging.hs | 302 ++++++++++++ .../Transport/QUIC/Internal/QUICAddr.hs | 81 +++ .../Transport/QUIC/Internal/QUICTransport.hs | 424 ++++++++++++++++ .../Network/Transport/QUIC/Internal/Server.hs | 51 ++ .../Network/Transport/QUIC/Internal/TLS.hs | 13 + packages/network-transport-quic/test/Main.hs | 16 + .../test/Test/Network/Transport/QUIC.hs | 76 +++ .../Transport/QUIC/Internal/Messaging.hs | 52 ++ .../Transport/QUIC/Internal/QUICAddr.hs | 57 +++ .../test/credentials/cert.crt | 22 + .../test/credentials/cert.key | 28 ++ .../src/Network/Transport/TCP.hs | 2 + 18 files changed, 1869 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/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..4b05a39d --- /dev/null +++ b/packages/network-transport-quic/network-transport-quic.cabal @@ -0,0 +1,97 @@ +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: async + , attoparsec + , base >= 4.14 && < 5 + , binary >= 0.8 && < 0.10 + , bytestring >= 0.10 && < 0.13 + , containers + , ip ^>=1.7 + , microlens-platform ^>=0.4 + , network >= 3.1 && < 3.3 + , network-transport >= 0.5 && < 0.6 + -- Prior to version 0.2.20, `quic` had issues with handling + -- pending data in the stream buffer. This meant that vectored + -- message sends did not work correctly at the transport layer + , quic >=0.2.20 && <0.3 + , 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.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-flaky + , tasty-hedgehog + , tasty-hunit + , text 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..e3a3b993 --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal.hs @@ -0,0 +1,463 @@ +{-# 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 (forkIO, killThread, modifyMVar_, newEmptyMVar, readMVar) +import Control.Concurrent.MVar (modifyMVar, putMVar, takeMVar, withMVar) +import Control.Concurrent.STM (atomically, newTQueueIO) +import Control.Concurrent.STM.TQueue ( + TQueue, + readTQueue, + writeTQueue, + ) +import Control.Exception (Exception (displayException), IOException, bracket, throwIO, try) +import Control.Monad (unless, when) +import Data.Bifunctor (Bifunctor (first)) +import Data.Binary qualified as Binary (decodeOrFail) +import Data.ByteString (StrictByteString, fromStrict) +import Data.Foldable (forM_) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict qualified as Map +import Data.Maybe (isNothing) +import GHC.Stack (HasCallStack) +import Lens.Micro.Platform ((+~)) +import Network.QUIC qualified as QUIC +import Network.Socket (HostName, ServiceName) +import Network.TLS (Credential) +import Network.Transport ( + ConnectErrorCode (ConnectFailed), + ConnectHints, + Connection (..), + EndPoint (..), + EndPointAddress, + Event (..), + EventErrorCode (EventConnectionLost), + NewEndPointErrorCode, + NewMulticastGroupErrorCode (NewMulticastGroupUnsupported), + Reliability (ReliableOrdered), + ResolveMulticastGroupErrorCode (ResolveMulticastGroupUnsupported), + SendErrorCode (SendClosed, SendFailed), + Transport (..), + TransportError (..), + ) +import Network.Transport.QUIC.Internal.Configuration (credentialLoadX509) +import Network.Transport.QUIC.Internal.Messaging ( + ClientConnId, + MessageReceived (..), + createConnectionId, + decodeMessage, + encodeMessage, + receiveMessage, + recvWord32, + sendAck, + sendCloseConnection, + sendMessage, + sendRejection, + serverSelfConnId, + ) +import Network.Transport.QUIC.Internal.QUICAddr (QUICAddr (..), decodeQUICAddr, encodeQUICAddr) +import Network.Transport.QUIC.Internal.QUICTransport ( + Direction (..), + LocalEndPoint, + LocalEndPointState (LocalEndPointStateClosed, LocalEndPointStateValid), + QUICTransport, + RemoteEndPoint (..), + RemoteEndPointState (..), + TransportState (..), + ValidRemoteEndPointState (..), + closeLocalEndpoint, + closeRemoteEndPoint, + createConnectionTo, + createRemoteEndPoint, + foldOpenEndPoints, + localAddress, + localEndPointState, + localEndPoints, + localQueue, + newLocalEndPoint, + newQUICTransport, + nextSelfConnOutId, + remoteEndPointAddress, + remoteEndPointState, + remoteIncoming, + remoteServerConnId, + remoteStream, + transportInputSocket, + 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 serviceName creds = do + quicTransport <- newQUICTransport host serviceName + + serverThread <- + forkServer + (quicTransport ^. transportInputSocket) + creds + throwIO + throwIO + (handleNewStream quicTransport) + + pure $ + Transport + { newEndPoint = newTQueueIO >>= newEndpoint quicTransport creds + , closeTransport = + foldOpenEndPoints quicTransport (closeLocalEndpoint quicTransport) + >> killThread serverThread -- TODO: use a synchronization mechanism to close the thread gracefully + >> modifyMVar_ + (quicTransport ^. transportState) + (\_ -> pure TransportStateClosed) + } + +{- | 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. + recvWord32 stream + >>= either (throwIO . userError) (pure . fromIntegral) + >>= QUIC.recvStream stream + >>= \payload -> do + case Binary.decodeOrFail (fromStrict payload) of + Left (_, _, errmsg) -> + throwIO (userError $ "(handleNewStream) remote endpoint address in handshake could not be decoded: " <> errmsg) + Right (_, _, (remoteAddress, endpointId)) -> + readMVar (quicTransport ^. transportState) >>= \case + TransportStateClosed -> throwIO $ userError "Transport closed" + TransportStateValid state -> case Map.lookup endpointId (state ^. localEndPoints) of + Nothing -> sendRejection stream + Just ourEndPoint -> do + readMVar (ourEndPoint ^. localEndPointState) >>= \case + LocalEndPointStateClosed -> sendRejection stream + LocalEndPointStateValid _ -> do + sendAck stream + + -- TODO: this may not be the first connection from this remote address. + -- In this case, we want to re-use the existing remote endpoint + (remoteEndPoint, _) <- either throwIO pure =<< createRemoteEndPoint ourEndPoint remoteAddress Incoming + doneMVar <- newEmptyMVar + + -- Sending an ack is important, because otherwise + -- the client may start sending messages well before we + -- start being able to receive them + + clientConnId <- either (throwIO . userError) (pure . fromIntegral) =<< recvWord32 stream + let serverConnId = remoteServerConnId remoteEndPoint + connectionId = createConnectionId serverConnId clientConnId + + let st = + RemoteEndPointValid $ + ValidRemoteEndPointState + { _remoteStream = stream + , _remoteStreamIsClosed = doneMVar + , _remoteIncoming = Just clientConnId + , _remoteNextConnOutId = 0 + } + modifyMVar_ + (remoteEndPoint ^. remoteEndPointState) + ( \case + RemoteEndPointInit -> pure st + _ -> undefined + ) + + tid <- + forkIO $ + -- If we've reached this stage, the connection handhake succeeded + handleIncomingMessages + ourEndPoint + remoteEndPoint + + atomically $ + writeTQueue + (ourEndPoint ^. localQueue) + ( ConnectionOpened + connectionId + ReliableOrdered + remoteAddress + ) + + takeMVar doneMVar + QUIC.shutdownStream stream + killThread tid + +{- | Infinite loop that listens for messages from the remote endpoint and processes them. + +This function assumes that the handshake has been completed. +-} +handleIncomingMessages :: (HasCallStack) => LocalEndPoint -> RemoteEndPoint -> IO () +handleIncomingMessages ourEndPoint remoteEndPoint = + bracket acquire release go + where + serverConnId = remoteServerConnId remoteEndPoint + ourQueue = ourEndPoint ^. localQueue + remoteAddress = remoteEndPoint ^. remoteEndPointAddress + remoteState = remoteEndPoint ^. remoteEndPointState + + acquire :: IO (Either IOError QUIC.Stream) + acquire = withMVar remoteState $ \case + RemoteEndPointInit -> pure . Left $ userError "handleIncomingMessages (init)" + RemoteEndPointClosed -> pure . Left $ userError "handleIncomingMessages (closed)" + RemoteEndPointValid validState -> pure . Right $ validState ^. remoteStream + + release :: Either IOError QUIC.Stream -> IO () + release (Left err) = closeRemoteEndPoint Incoming remoteEndPoint >> prematureExit err + release (Right _) = closeRemoteEndPoint Incoming remoteEndPoint + + connectionId connId = createConnectionId serverConnId connId + + writeConnectionClosedSTM connId = + writeTQueue + ourQueue + (ConnectionClosed (connectionId connId)) + + go = either prematureExit loop + + loop stream = + receiveMessage stream + >>= \case + Left errmsg -> do + -- Throwing will trigger 'prematureExit' + throwIO $ userError $ "(handleIncomingMessages) Failed with: " <> errmsg + Right (Message connId bytes) -> handleMessage connId bytes >> loop stream + Right StreamClosed -> throwIO $ userError "(handleIncomingMessages) Stream closed" + Right (CloseConnection connId) -> do + atomically (writeConnectionClosedSTM connId) + mAct <- modifyMVar (remoteEndPoint ^. remoteEndPointState) $ \case + RemoteEndPointInit -> pure (RemoteEndPointClosed, Nothing) + RemoteEndPointClosed -> pure (RemoteEndPointClosed, Nothing) + RemoteEndPointValid (ValidRemoteEndPointState _ isClosed _ _) -> do + pure (RemoteEndPointClosed, Just $ putMVar isClosed ()) + case mAct of + Nothing -> pure () + Just cleanup -> cleanup + Right CloseEndPoint -> do + connIds <- modifyMVar (remoteEndPoint ^. remoteEndPointState) $ \case + RemoteEndPointValid vst -> do + -- TODO: check how many connections are outgoing + pure (RemoteEndPointClosed, vst ^. remoteIncoming) + other -> pure (other, Nothing) + unless + (isNothing connIds) + ( atomically $ + forM_ + connIds + (writeTQueue ourQueue . ConnectionClosed . connectionId) + ) + + handleMessage :: ClientConnId -> StrictByteString -> IO () + handleMessage clientConnId payload = + atomically (writeTQueue ourQueue (Received (connectionId clientConnId) [payload])) + + prematureExit :: IOException -> IO () + prematureExit exc = do + modifyMVar_ remoteState $ \case + RemoteEndPointValid{} -> pure RemoteEndPointClosed + other -> pure other + atomically + ( writeTQueue + ourQueue + ( ErrorEvent + ( TransportError + (EventConnectionLost remoteAddress) + (displayException exc) + ) + ) + ) + +newEndpoint :: + QUICTransport -> + NonEmpty Credential -> + TQueue Event -> + IO (Either (TransportError NewEndPointErrorCode) EndPoint) +newEndpoint quicTransport creds newLocalQueue = do + newLocalEndPoint quicTransport newLocalQueue >>= \case + Left err -> pure $ Left err + Right ourEndPoint -> + 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 = closeLocalEndpoint quicTransport ourEndPoint + } + +newConnection :: + LocalEndPoint -> + NonEmpty Credential -> + EndPointAddress -> + Reliability -> + ConnectHints -> + IO (Either (TransportError ConnectErrorCode) Connection) +newConnection ourEndPoint creds remoteAddress _reliability _connectHints = + if ourAddress == remoteAddress + then connectToSelf ourEndPoint + else + createConnectionTo creds ourEndPoint remoteAddress >>= \case + Left err -> pure $ Left err + Right (remoteEndPoint, connId) -> do + connAlive <- newIORef True + pure + . Right + $ Connection + { send = sendConn remoteEndPoint connAlive connId + , close = closeConn remoteEndPoint connAlive connId + } + where + ourAddress = ourEndPoint ^. localAddress + sendConn remoteEndPoint connAlive connId packets = + readMVar (remoteEndPoint ^. remoteEndPointState) >>= \case + RemoteEndPointInit -> undefined + RemoteEndPointValid vst -> + readIORef connAlive >>= \case + False -> pure . Left $ TransportError SendClosed "Connection closed" + True -> do + sendMessage (vst ^. remoteStream) connId packets + <&> (first (TransportError SendFailed . show)) + RemoteEndPointClosed -> do + readIORef connAlive >>= \case + -- This is normal. If the remote endpoint closes up while we have + -- an outgoing connection (CloseEndPoint or CloseSocket message), + -- we'll post the connection lost event but we won't update these + -- 'connAlive' IORefs. + False -> pure . Left $ TransportError SendClosed "Connection closed" + True -> pure . Left $ TransportError SendFailed "Remote endpoint closed" + closeConn remoteEndPoint connAlive connId = do + mCleanup <- modifyMVar (remoteEndPoint ^. remoteEndPointState) $ \case + RemoteEndPointValid vst@(ValidRemoteEndPointState stream isClosed _ _) -> do + readIORef connAlive >>= \case + False -> pure (RemoteEndPointValid vst, Nothing) + True -> do + writeIORef connAlive False + -- We want to run this cleanup action OUTSIDE of the MVar modification + let cleanup = sendCloseConnection connId stream + pure (RemoteEndPointClosed, Just $ cleanup >> putMVar isClosed ()) + _ -> pure (RemoteEndPointClosed, Nothing) + + case mCleanup of + Nothing -> pure () + Just cleanup -> cleanup + +connectToSelf :: + LocalEndPoint -> + IO (Either (TransportError ConnectErrorCode) Connection) +connectToSelf ourEndPoint = do + connAlive <- newIORef True + modifyMVar + (ourEndPoint ^. localEndPointState) + ( \case + LocalEndPointStateClosed -> + pure + ( LocalEndPointStateClosed + , Left $ TransportError ConnectFailed "Local endpoint closed" + ) + LocalEndPointStateValid vst -> + pure + ( LocalEndPointStateValid $ vst & nextSelfConnOutId +~ 1 + , Right $ vst ^. nextSelfConnOutId + ) + ) + >>= \case + Left err -> pure $ Left err + Right clientConnId -> do + let connId = createConnectionId serverSelfConnId clientConnId + atomically $ + writeTQueue + queue + ( ConnectionOpened + connId + ReliableOrdered + (ourEndPoint ^. localAddress) + ) + pure . Right $ + Connection + { send = selfSend connAlive connId + , close = selfClose connAlive connId + } + where + queue = ourEndPoint ^. localQueue + selfSend connAlive connId msg = + try . withMVar (ourEndPoint ^. localEndPointState) $ \st -> case st of + LocalEndPointStateValid _ -> do + alive <- readIORef connAlive + if alive + then + seq + (foldr seq () msg) + ( atomically $ + writeTQueue + queue + (Received connId msg) + ) + else throwIO $ TransportError SendClosed "Connection closed" + LocalEndPointStateClosed -> + throwIO $ TransportError SendFailed "Endpoint closed" + + selfClose connAlive connId = + withMVar (ourEndPoint ^. localEndPointState) $ \st -> case st of + LocalEndPointStateValid _ -> do + alive <- readIORef connAlive + when alive $ do + atomically $ writeTQueue queue (ConnectionClosed connId) + writeIORef connAlive False + LocalEndPointStateClosed -> + return () 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..0cf39822 --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Client.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Network.Transport.QUIC.Internal.Client ( + streamToEndpoint, +) +where + +import Control.Concurrent (forkIOWithUnmask, newEmptyMVar) +import Control.Concurrent.Async (withAsync) +import Control.Concurrent.MVar (MVar, putMVar, takeMVar) +import Control.Exception (SomeException, bracket, catch, mask, mask_, throwIO) +import Data.List.NonEmpty (NonEmpty) +import Network.QUIC qualified as QUIC +import Network.QUIC.Client qualified as QUIC.Client +import Network.Transport (ConnectErrorCode (ConnectNotFound), EndPointAddress, TransportError (..)) +import Network.Transport.QUIC.Internal.Configuration (Credential, mkClientConfig) +import Network.Transport.QUIC.Internal.Messaging (MessageReceived (..), handshake, receiveMessage) +import Network.Transport.QUIC.Internal.QUICAddr (QUICAddr (QUICAddr), decodeQUICAddr) + +streamToEndpoint :: + NonEmpty Credential -> + -- | Our address + EndPointAddress -> + -- | Their address + EndPointAddress -> + -- | On exception + (SomeException -> IO ()) -> + -- | On a message to forcibly close the connection + (IO ()) -> + IO + ( Either + (TransportError ConnectErrorCode) + ( MVar () + , -- \^ put '()' to close the stream + QUIC.Stream + ) + ) +streamToEndpoint creds ourAddress theirAddress onExc onCloseForcibly = + case decodeQUICAddr theirAddress of + Left errmsg -> pure $ Left (TransportError ConnectNotFound errmsg) + Right (QUICAddr hostname servicename _) -> do + clientConfig <- mkClientConfig hostname servicename creds + + streamMVar <- newEmptyMVar + doneMVar <- newEmptyMVar + + let runClient :: QUIC.Connection -> IO () + runClient conn = mask $ \restore -> do + QUIC.waitEstablished conn + restore $ + bracket (QUIC.stream conn) QUIC.closeStream $ \stream -> do + handshake (ourAddress, theirAddress) stream + >>= either + (\_ -> putMVar streamMVar (Left $ TransportError ConnectNotFound "handshake failed")) + (\_ -> putMVar streamMVar (Right stream)) + + withAsync (listenForClose stream doneMVar) $ \_ -> + takeMVar doneMVar + + _ <- mask_ $ + forkIOWithUnmask $ + \unmask -> + catch + ( unmask $ + QUIC.Client.run + clientConfig + ( \conn -> + catch + (runClient conn) + (throwIO @SomeException) + ) + ) + onExc + + streamOrError <- takeMVar streamMVar + + pure $ (doneMVar,) <$> streamOrError + where + listenForClose :: QUIC.Stream -> MVar () -> IO () + listenForClose stream doneMVar = + receiveMessage stream + >>= \case + Right StreamClosed -> do + putMVar doneMVar () + Right (CloseConnection _) -> do + putMVar doneMVar () + Right CloseEndPoint -> do + putMVar doneMVar () + onCloseForcibly + other -> throwIO . userError $ "Unexpected incoming message to client: " <> show other \ 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..91665553 --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Configuration.hs @@ -0,0 +1,56 @@ +{-# 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 (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) + -- The following two parameters are for debugging. TODO: turn off by default + -- ccDebugLog = True + -- , ccKeyLog = putStrLn + } + +mkServerConfig :: + NonEmpty Credential -> + IO ServerConfig +mkServerConfig creds = do + tlsSessionManager <- TLS.sessionManager + + pure $ + defaultServerConfig + { 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 + -- } + } 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..7a42ec6f --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Messaging.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Network.Transport.QUIC.Internal.Messaging ( + -- * Connections + ServerConnId, + serverSelfConnId, + firstNonReservedServerConnId, + ClientConnId, + createConnectionId, + sendMessage, + receiveMessage, + MessageReceived (..), + + -- * Specialized messages + sendAck, + sendRejection, + recvAck, + recvWord32, + sendCloseConnection, + sendCloseEndPoint, + + -- * Handshake protocol + handshake, + + -- * Re-exported for testing + encodeMessage, + decodeMessage, +) where + +import Control.Exception (catch, mask, throwIO, try) +import Data.Binary (Binary) +import Data.Binary qualified as Binary +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 (ConnectionId, EndPointAddress) +import Network.Transport.QUIC.Internal.QUICAddr (QUICAddr (QUICAddr), decodeQUICAddr) +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 -> + ClientConnId -> + [StrictByteString] -> + IO (Either QUIC.QUICException ()) +sendMessage stream connId message = + try + (QUIC.sendStreamMany stream (encodeMessage connId message)) + +{- | 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 :: + ClientConnId -> + [StrictByteString] -> + [StrictByteString] +encodeMessage connId messages = + -- For simplicity, we are keeping the message boundaries, and adding + -- a header for each message. + -- + -- We could also merge all messages together, and have a single + -- header, but this requires specifying some message framing + fmap withHeader messages + where + withHeader message = + toStrict $ + Builder.toLazyByteString $ + Builder.word8 messageControlByte + <> Builder.word32BE (fromIntegral connId) + <> Builder.word32BE (fromIntegral (BS.length message)) + <> Builder.byteString message + +decodeMessage :: (Int -> IO StrictByteString) -> IO (Either String MessageReceived) +decodeMessage getBytes = + getBytes 1 <&> BS.unpack >>= \case + [] -> pure $ Right StreamClosed + [ctrl] -> go ctrl + other -> pure . Left $ "Unexpected control byte: " <> show other + where + go ctrl + | ctrl == closeEndPointControlByte = pure $ Right CloseEndPoint + | otherwise = + getBytes 4 <&> BS.unpack >>= \case + [c1, c2, c3, c4] + | ctrl == messageControlByte -> + getBytes 4 + >>= ( \case + [l1, l2, l3, l4] -> + let connId = fromIntegral $ w32BE c1 c2 c3 c4 + messageLength = fromIntegral $ w32BE l1 l2 l3 l4 + in getBytes messageLength <&> Right . Message connId + _ -> pure $ Left "Malformed message" + ) + . BS.unpack + | ctrl == closeConnectionControlByte -> do + pure . Right . CloseConnection $ fromIntegral $ w32BE c1 c2 c3 c4 + | otherwise -> + pure $ Left $ "Unsupported control byte: " <> show ctrl + _ -> pure . Left $ "Message content could not be parsed" + +data MessageReceived + = Message !ClientConnId !StrictByteString + | CloseConnection !ClientConnId + | CloseEndPoint + | StreamClosed + deriving (Show, Eq) + +-- | 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.word8 connectionAcceptedControlByte)) + +rejectMessage :: StrictByteString +rejectMessage = toStrict (Builder.toLazyByteString (Builder.word8 connectionRejectedControlByte)) + +sendAck :: Stream -> IO () +sendAck = + flip + QUIC.sendStream + ackMessage + +sendRejection :: Stream -> IO () +sendRejection = + flip + QUIC.sendStream + rejectMessage + +recvAck :: Stream -> IO (Either () ()) +recvAck stream = do + -- TODO: make timeout configurable + timeout 500_000 (QUIC.recvStream stream 1) + >>= maybe + (throwIO (AckException "Connection ack not received within acceptable timeframe")) + go + where + go response + | response == ackMessage = pure $ Right () + | response == rejectMessage = pure $ Left () + | otherwise = throwIO (AckException "Unexpected ack response") + +{- | Receive a 'Word32' + +This function is thread-safe; while the data is being received, asynchronous +exceptions are masked, to be rethrown after the data is sent. +-} +recvWord32 :: + Stream -> + IO (Either String Word32) +recvWord32 stream = + mask $ \restore -> + restore + ( QUIC.recvStream stream 4 <&> BS.unpack >>= \case + [] -> pure . Left $ "Stream closed" + [l1, l2, l3, l4] -> pure . Right $ w32BE l1 l2 l3 l4 + xs -> pure . Left $ "Unexpected incoming data: " <> show xs + ) + `catch` (\(ex :: QUIC.QUICException) -> throwIO ex) + +{- | We perform some special actions based on a message's control byte. +For example, if a client wants to close a connection. +-} +type ControlByte = Word8 + +connectionAcceptedControlByte :: ControlByte +connectionAcceptedControlByte = 0 + +connectionRejectedControlByte :: ControlByte +connectionRejectedControlByte = 1 + +messageControlByte :: ControlByte +messageControlByte = 2 + +closeEndPointControlByte :: ControlByte +closeEndPointControlByte = 127 + +closeConnectionControlByte :: ControlByte +closeConnectionControlByte = 255 + +-- | Send a message to close the connection. +sendCloseConnection :: ClientConnId -> Stream -> IO (Either QUIC.QUICException ()) +sendCloseConnection connId stream = + try + ( QUIC.sendStream + stream + ( toStrict $ + Builder.toLazyByteString $ + Builder.word8 closeConnectionControlByte + <> Builder.word32BE (fromIntegral connId) + ) + ) + +-- | Send a message to close the connection. +sendCloseEndPoint :: Stream -> IO (Either QUIC.QUICException ()) +sendCloseEndPoint stream = + try + ( QUIC.sendStream + stream + ( toStrict $ + Builder.toLazyByteString $ + Builder.word8 closeEndPointControlByte + ) + ) + +{- | Handshake protocol that a client, connecting to a remote endpoint, +has to perform. +-} + +-- TODO: encode server part of the handhake +handshake :: + (EndPointAddress, EndPointAddress) -> + Stream -> + IO (Either () ()) +handshake (ourAddress, theirAddress) stream = + case decodeQUICAddr theirAddress of + Left errmsg -> throwIO $ userError ("Could not decode QUIC address: " <> errmsg) + Right (QUICAddr _ _ serverEndPointId) -> do + -- Handshake on connection creation, which simply involves + -- sending our address over, and + -- the endpoint ID of the endpoint we want to communicate with + let encodedPayload = BS.toStrict $ Binary.encode (ourAddress, serverEndPointId) + payloadLength = BS.toStrict . Binary.encode $ fromIntegral @Int @Word32 (BS.length encodedPayload) + + QUIC.sendStreamMany + stream + [payloadLength, encodedPayload] + + -- Server acknowledgement that the handshake is complete + -- means that we cannot send messages until the server + -- is ready for them + recvAck stream + +-- | Part of the connection ID that is client-allocated. +newtype ClientConnId = ClientConnId Word32 + deriving newtype (Eq, Show, Ord, Bounded, Enum, Real, Integral, Num, Binary) + +-- | Part of the connection ID that is server-allocated. +newtype ServerConnId = ServerConnId Word32 + deriving newtype (Eq, Show, Ord, Bounded, Enum, Real, Integral, Num) + +-- | Self-connection +serverSelfConnId :: ServerConnId +serverSelfConnId = 0 + +-- | We reserve some connection IDs for special heavyweight connections +firstNonReservedServerConnId :: ServerConnId +firstNonReservedServerConnId = 1 + +-- | Construct a ConnectionId +createConnectionId :: + ServerConnId -> + ClientConnId -> + ConnectionId +createConnectionId sid cid = + (fromIntegral sid `shiftL` 32) .|. fromIntegral cid \ 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..da6270ba --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICAddr.hs @@ -0,0 +1,81 @@ +{-# 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.Binary (Binary) +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, Binary) + +-- 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..c97b9c01 --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/QUICTransport.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Network.Transport.QUIC.Internal.QUICTransport ( + -- * QUICTransport + QUICTransport, + newQUICTransport, + foldOpenEndPoints, + transportHost, + transportPort, + transportInputSocket, + transportState, + + -- * TransportState + TransportState (..), + localEndPoints, + nextEndPointId, + + -- * LocalEndPoint + LocalEndPoint, + localAddress, + localEndPointId, + localEndPointState, + localQueue, + nextConnInId, + nextSelfConnOutId, + newLocalEndPoint, + closeLocalEndpoint, + + -- * LocalEndPointState + LocalEndPointState (..), + ValidLocalEndPointState, + incomingConnections, + outgoingConnections, + nextConnectionCounter, + + -- ** ConnectionCounter + ConnectionCounter, + + -- * RemoteEndPoint + RemoteEndPoint (..), + remoteEndPointAddress, + remoteEndPointId, + remoteServerConnId, + remoteEndPointState, + closeRemoteEndPoint, + createRemoteEndPoint, + createConnectionTo, + + -- ** Remote endpoint state + RemoteEndPointState (..), + ValidRemoteEndPointState (..), + remoteStream, + remoteStreamIsClosed, + remoteIncoming, + remoteNextConnOutId, + Direction (..), + + -- * Re-exports + (^.), +) where + +import Control.Concurrent.Async (forConcurrently_) +import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar, putMVar, readMVar) +import Control.Concurrent.STM.TQueue (TQueue, writeTQueue) +import Control.Exception (Exception (displayException), SomeException, bracketOnError, try) +import Control.Monad (forM_) +import Control.Monad.STM (atomically) +import Data.Binary qualified as Binary +import Data.ByteString qualified as BS +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Word (Word32) +import Lens.Micro.Platform (makeLenses, (%~), (+~), (^.)) +import Network.QUIC (Stream) +import Network.QUIC qualified as QUIC +import Network.Socket (HostName, ServiceName, Socket) +import Network.Socket qualified as N +import Network.TLS (Credential) +import Network.Transport (ConnectErrorCode (ConnectFailed), EndPointAddress, Event (EndPointClosed, ErrorEvent), EventErrorCode (EventConnectionLost), NewEndPointErrorCode (NewEndPointFailed), TransportError (TransportError)) +import Network.Transport.QUIC.Internal.Client (streamToEndpoint) +import Network.Transport.QUIC.Internal.Messaging ( + ClientConnId, + ServerConnId, + firstNonReservedServerConnId, + sendCloseConnection, + sendCloseEndPoint, + ) +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 + , _transportInputSocket :: Socket + , _transportState :: MVar TransportState + } + +data TransportState + = TransportStateValid ValidTransportState + | TransportStateClosed + +data ValidTransportState = ValidTransportState + { _localEndPoints :: !(Map EndPointId LocalEndPoint) + , _nextEndPointId :: !EndPointId + } + +-- | Create a new QUICTransport +newQUICTransport :: HostName -> ServiceName -> IO QUICTransport +newQUICTransport host serviceName = do + addr <- NE.head <$> N.getAddrInfo (Just N.defaultHints) (Just host) (Just serviceName) + bracketOnError + ( N.socket + (N.addrFamily addr) + N.Datagram -- QUIC is based on UDP + N.defaultProtocol + ) + N.close + $ \socket -> do + N.setSocketOption socket N.ReuseAddr 1 + N.withFdSocket socket N.setCloseOnExecIfNeeded + N.bind socket (N.addrAddress addr) + + port <- N.socketPort socket + QUICTransport + host + (show port) + socket + <$> newMVar (TransportStateValid $ ValidTransportState mempty 1) + +data LocalEndPoint = OpenLocalEndPoint + { _localAddress :: !EndPointAddress + , _localEndPointId :: !EndPointId + , _localEndPointState :: !(MVar LocalEndPointState) + , _localQueue :: !(TQueue Event) + -- ^ Queue used to receive events + } + +{- | A 'ConnectionCounter' uniquely identifies a connections within the context of an endpoint. +This allows to hold multiple separate connections between two endpoint addresses. + +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 ConnectionCounter = ConnectionCounter Word32 + deriving newtype (Eq, Show, Ord, Bounded, Enum, Real, Integral, Num) + +data LocalEndPointState + = LocalEndPointStateValid ValidLocalEndPointState + | LocalEndPointStateClosed + deriving (Show) + +data ValidLocalEndPointState = ValidLocalEndPointState + { _incomingConnections :: Map (EndPointAddress, ConnectionCounter) RemoteEndPoint + , _outgoingConnections :: Map (EndPointAddress, ConnectionCounter) RemoteEndPoint + , _nextSelfConnOutId :: !ClientConnId + , _nextConnInId :: !ServerConnId + {- ^ We identify connections by remote endpoint address, AND ConnectionCounter, + to support multiple connections between the same two endpoint addresses + -} + , _nextConnectionCounter :: ConnectionCounter + } + deriving (Show) + +data RemoteEndPoint = RemoteEndPoint + { _remoteEndPointAddress :: !EndPointAddress + , _remoteEndPointId :: !EndPointId + , _remoteEndPointState :: !(MVar RemoteEndPointState) + } + +remoteServerConnId :: RemoteEndPoint -> ServerConnId +remoteServerConnId = fromIntegral . _remoteEndPointId + +instance Show RemoteEndPoint where + show (RemoteEndPoint address _ _) = " show address <> ">" + +data RemoteEndPointState + = {- | In the short window between a connection + being initiated and the handshake completing + -} + RemoteEndPointInit + | RemoteEndPointValid ValidRemoteEndPointState + | RemoteEndPointClosed + +data ValidRemoteEndPointState = ValidRemoteEndPointState + { _remoteStream :: Stream + , _remoteStreamIsClosed :: MVar () + , _remoteIncoming :: !(Maybe ClientConnId) + , _remoteNextConnOutId :: !ClientConnId + } + +makeLenses ''QUICTransport +makeLenses ''TransportState +makeLenses ''ValidTransportState +makeLenses ''LocalEndPoint +makeLenses ''LocalEndPointState +makeLenses ''ValidLocalEndPointState +makeLenses ''RemoteEndPoint +makeLenses ''ValidRemoteEndPointState + +-- | Fold over all open local endpoitns of a transport +foldOpenEndPoints :: QUICTransport -> (LocalEndPoint -> IO a) -> IO [a] +foldOpenEndPoints quicTransport f = + readMVar (quicTransport ^. transportState) >>= \case + TransportStateClosed -> pure [] + TransportStateValid st -> + mapM f (Map.elems $ st ^. localEndPoints) + +newLocalEndPoint :: QUICTransport -> TQueue Event -> IO (Either (TransportError NewEndPointErrorCode) LocalEndPoint) +newLocalEndPoint quicTransport newLocalQueue = do + modifyMVar (quicTransport ^. transportState) $ \state -> case state of + TransportStateClosed -> pure $ (TransportStateClosed, Left $ TransportError NewEndPointFailed "Transport closed") + TransportStateValid validState -> do + let newEndPointId = validState ^. nextEndPointId + + newLocalState <- + newMVar + ( LocalEndPointStateValid $ + ValidLocalEndPointState + { _incomingConnections = mempty + , _outgoingConnections = mempty + , _nextConnInId = firstNonReservedServerConnId + , _nextSelfConnOutId = 0 + , _nextConnectionCounter = 0 + } + ) + let openEndpoint = + OpenLocalEndPoint + { _localAddress = + encodeQUICAddr + ( QUICAddr + (quicTransport ^. transportHost) + (quicTransport ^. transportPort) + newEndPointId + ) + , _localEndPointId = newEndPointId + , _localEndPointState = newLocalState + , _localQueue = newLocalQueue + } + + pure + ( TransportStateValid + ( validState + & localEndPoints %~ Map.insert newEndPointId openEndpoint + & nextEndPointId +~ 1 + ) + , Right openEndpoint + ) + +closeLocalEndpoint :: + QUICTransport -> + LocalEndPoint -> + IO () +closeLocalEndpoint quicTransport localEndPoint = do + modifyMVar_ (quicTransport ^. transportState) $ \case + TransportStateClosed -> pure TransportStateClosed + TransportStateValid vst -> + pure . TransportStateValid $ + vst + & localEndPoints + %~ Map.delete (localEndPoint ^. localEndPointId) + + mPreviousState <- modifyMVar (localEndPoint ^. localEndPointState) $ \case + LocalEndPointStateClosed -> pure (LocalEndPointStateClosed, Nothing) + LocalEndPointStateValid st -> pure (LocalEndPointStateClosed, Just st) + + forM_ mPreviousState $ \vst -> + forConcurrently_ + (vst ^. incomingConnections <> vst ^. outgoingConnections) + tryCloseRemoteStream + atomically $ writeTQueue (localEndPoint ^. localQueue) EndPointClosed + where + tryCloseRemoteStream :: RemoteEndPoint -> IO () + tryCloseRemoteStream remoteEndPoint = do + mCleanup <- modifyMVar (remoteEndPoint ^. remoteEndPointState) $ \case + RemoteEndPointInit -> pure (RemoteEndPointClosed, Nothing) + RemoteEndPointClosed -> pure (RemoteEndPointClosed, Nothing) + RemoteEndPointValid vst -> + pure + ( RemoteEndPointClosed + , Just $ do + sendCloseEndPoint (vst ^. remoteStream) + >> putMVar (vst ^. remoteStreamIsClosed) () + ) + + case mCleanup of + Nothing -> pure () + Just cleanup -> cleanup + +{- | Attempt to close a remote endpoint. If the remote endpoint is in +any non-valid state (e.g. already closed), then nothing happens. + +Otherwise, a control message is sent to the remote end to nicely ask to +close this connection. +-} +closeRemoteEndPoint :: Direction -> RemoteEndPoint -> IO () +closeRemoteEndPoint direction remoteEndPoint = do + mAct <- modifyMVar (remoteEndPoint ^. remoteEndPointState) $ \case + RemoteEndPointInit -> pure (RemoteEndPointClosed, Nothing) + RemoteEndPointClosed -> pure (RemoteEndPointClosed, Nothing) + RemoteEndPointValid (ValidRemoteEndPointState stream isClosed conns _) -> + let cleanup = + case direction of + Outgoing -> Right <$> forM_ conns (flip sendCloseConnection stream) + Incoming -> sendCloseEndPoint stream + >> putMVar isClosed () + in pure (RemoteEndPointClosed, Just cleanup) + + case mAct of + Nothing -> pure () + Just act -> act + +data Direction + = Outgoing + | Incoming + deriving (Eq, Show, Ord, Enum, Bounded) + +{- | Create a remote end point in the 'init' state. + +The resulting remote end point is NOT set up, such that +it could be set up separately to /receive/ messages, or /send/ them. +-} +createRemoteEndPoint :: + LocalEndPoint -> + EndPointAddress -> + Direction -> + IO (Either (TransportError ConnectErrorCode) (RemoteEndPoint, ConnectionCounter)) +createRemoteEndPoint localEndPoint remoteAddress direction = do + modifyMVar (localEndPoint ^. localEndPointState) $ \case + LocalEndPointStateClosed -> pure $ (LocalEndPointStateClosed, Left $ TransportError ConnectFailed "endpoint is closed") + LocalEndPointStateValid st -> do + remoteEndPoint <- + RemoteEndPoint + remoteAddress + -- The design of using the next Server connection ID + -- as the RemoteId comes from the TCP transport + + (fromIntegral $ st ^. nextConnInId) + <$> newMVar RemoteEndPointInit + pure $ + ( LocalEndPointStateValid $ + st + & (if direction == Incoming then incomingConnections else outgoingConnections) %~ Map.insert (remoteAddress, st ^. nextConnectionCounter) remoteEndPoint + & nextConnectionCounter +~ 1 + & nextConnInId +~ 1 + , Right (remoteEndPoint, st ^. nextConnectionCounter) + ) + +{- | Create a remote end point, set up as a client that connects +to the remote 'EndPointAddress'. +-} +createConnectionTo :: + NonEmpty Credential -> + LocalEndPoint -> + EndPointAddress -> + IO (Either (TransportError ConnectErrorCode) (RemoteEndPoint, ClientConnId)) +createConnectionTo creds localEndPoint remoteAddress = do + createRemoteEndPoint localEndPoint remoteAddress Outgoing >>= \case + Left err -> pure $ Left err + Right (remoteEndPoint, _) -> + streamToEndpoint + creds + (localEndPoint ^. localAddress) + remoteAddress + (\_ -> closeRemoteEndPoint Outgoing remoteEndPoint) + onConnectionLost + >>= \case + Left exc -> pure $ Left exc + Right (closeStream, stream) -> do + let clientConnId = 0 + validState = + RemoteEndPointValid $ + ValidRemoteEndPointState + { _remoteStream = stream + , _remoteStreamIsClosed = closeStream + , _remoteIncoming = Nothing + , _remoteNextConnOutId = clientConnId + 1 + } + modifyMVar_ + (remoteEndPoint ^. remoteEndPointState) + (\_ -> pure validState) + + try + ( QUIC.sendStream + stream + ( BS.toStrict $ + Binary.encode clientConnId + ) + ) + >>= \case + Left (exc :: SomeException) -> pure . Left $ TransportError ConnectFailed (displayException exc) + Right () -> pure $ Right (remoteEndPoint, clientConnId) + where + onConnectionLost = + atomically + . writeTQueue (localEndPoint ^. localQueue) + . ErrorEvent + $ TransportError + (EventConnectionLost remoteAddress) + "Connection reset" 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..ee7195cb --- /dev/null +++ b/packages/network-transport-quic/src/Network/Transport/QUIC/Internal/Server.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Network.Transport.QUIC.Internal.Server (forkServer) where + +import Control.Concurrent (ThreadId, forkIOWithUnmask) +import Control.Exception (SomeException, catch, finally, mask, mask_) +import Data.List.NonEmpty (NonEmpty) +import Network.QUIC qualified as QUIC +import Network.QUIC.Server qualified as QUIC.Server +import Network.Socket (Socket) +import Network.Transport.QUIC.Internal.Configuration (Credential, mkServerConfig) + +forkServer :: + Socket -> + 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. The stream is closed after this handler returns. + (QUIC.Stream -> IO ()) -> + IO ThreadId +forkServer socket creds errorHandler terminationHandler requestHandler = do + serverConfig <- mkServerConfig creds + + let acceptConnection :: QUIC.Connection -> IO () + acceptConnection conn = mask $ \restore -> do + QUIC.waitEstablished conn + stream <- QUIC.acceptStream conn + + catch + (restore (requestHandler stream `finally` QUIC.closeStream stream)) + errorHandler + + -- 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.runWithSockets [socket] 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..16555c2b --- /dev/null +++ b/packages/network-transport-quic/test/Test/Network/Transport/QUIC.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} + +module Test.Network.Transport.QUIC (tests) where + +import Control.Exception (bracket) +import Data.List.NonEmpty qualified as NonEmpty +import Network.Transport (Transport (..)) +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) +import Test.Tasty.Flaky (flakyTest, limitRetries) + +tests :: TestTree +tests = + testGroup + "Network.Transport.QUIC" + [ testCaseWithTimeout "ping-pong" $ withQUICTransport $ flip Tests.testPingPong 5 + , testCaseWithTimeout "endpoints" $ withQUICTransport $ flip Tests.testEndPoints 5 + , testCaseWithTimeout "connections" $ withQUICTransport $ flip Tests.testConnections 5 + , testCaseWithTimeout "closeOneConnection" $ withQUICTransport $ flip Tests.testCloseOneConnection 5 + , testCaseWithTimeout "closeOneDirection" $ withQUICTransport $ flip Tests.testCloseOneDirection 5 + , testCaseWithTimeout "closeReopen" $ withQUICTransport $ flip Tests.testCloseReopen 5 + , testCaseWithTimeout "parallelConnects" $ withQUICTransport $ flip Tests.testParallelConnects 5 + , testCaseWithTimeout "selfSend" $ withQUICTransport Tests.testSelfSend + , testCaseWithTimeout "sendAfterClose" $ withQUICTransport $ flip Tests.testSendAfterClose 5 + , testCaseWithTimeout "closeTwice" $ withQUICTransport $ flip Tests.testCloseTwice 1 -- This is a little flaky + , testCaseWithTimeout "connectToSelf" $ withQUICTransport $ flip Tests.testConnectToSelf 5 + , testCaseWithTimeout "connectToSelfTwice" $ withQUICTransport $ flip Tests.testConnectToSelfTwice 5 + , testCaseWithTimeout "closeSelf" $ withQUICTransport (Tests.testCloseSelf . pure . Right) + , testCaseWithTimeout "closeEndPoint" $ withQUICTransport $ flip Tests.testCloseEndPoint 1 + , testCaseWithTimeout "closeTransport" $ Tests.testCloseTransport mkQUICTransport + , flakyTest (limitRetries 1) $ testCaseWithTimeout "connectClosedEndPoint" $ withQUICTransport Tests.testConnectClosedEndPoint + ] + +-- | Ensure that a test does not run for too long +testCaseWithTimeout :: TestName -> Assertion -> TestTree +testCaseWithTimeout name assertion = + testCase name $ + timeout 1_000_000 assertion + >>= maybe (assertFailure "Test timed out") pure + +mkQUICTransport :: IO (Either String Transport) +mkQUICTransport = do + QUIC.credentialLoadX509 + -- Generate a self-signed x509v3 certificate using this nifty tool: + -- https://certificatetools.com/ + ("test" "credentials" "cert.crt") + ("test" "credentials" "cert.key") + >>= \case + Left errmsg -> pure $ Left errmsg + Right credentials -> + Right + <$> QUIC.createTransport "127.0.0.1" "0" (NonEmpty.singleton credentials) + +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" + "0" + . 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..44fb6f00 --- /dev/null +++ b/packages/network-transport-quic/test/Test/Network/Transport/QUIC/Internal/Messaging.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Network.Transport.QUIC.Internal.Messaging (tests) where + +import Control.Monad (replicateM) +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 connection ID and message length are encoded and decoded the same way, to/from + -- a Word32. + -- To exercise the parsing of Word32s, we need to make sure that the range + -- of data is generated above a Word8 (255), including the connection ID + -- and the number of bytes in the message + endpointId <- fmap fromIntegral <$> forAll $ Gen.word32 Range.constantBounded + + messages <- forAll (Gen.list (Range.linear 0 3) (Gen.bytes (Range.linear 1 2048))) + let encoded = mconcat $ encodeMessage endpointId messages + + getBytes <- liftIO $ messageDecoder encoded + + decoded <- liftIO $ replicateM (length messages) (decodeMessage getBytes) + (Right . Message endpointId <$> messages) === decoded + +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