network-transport-quic (empty) → 0.1.0
raw patch · 19 files changed
+2064/−0 lines, 19 filesdep +asyncdep +basedep +binary
Dependencies added: async, base, binary, bytestring, containers, filepath, hedgehog, microlens-platform, network, network-transport, network-transport-quic, network-transport-tcp, network-transport-tests, quic, stm, tasty, tasty-bench, tasty-flaky, tasty-hedgehog, tasty-hunit, tls, tls-session-manager
Files
- CHANGELOG.md +4/−0
- LICENSE +20/−0
- bench/Bench.hs +154/−0
- network-transport-quic.cabal +110/−0
- src/Network/Transport/QUIC.hs +22/−0
- src/Network/Transport/QUIC/Internal.hs +466/−0
- src/Network/Transport/QUIC/Internal/Client.hs +95/−0
- src/Network/Transport/QUIC/Internal/Configuration.hs +46/−0
- src/Network/Transport/QUIC/Internal/Messaging.hs +295/−0
- src/Network/Transport/QUIC/Internal/QUICAddr.hs +70/−0
- src/Network/Transport/QUIC/Internal/QUICTransport.hs +447/−0
- src/Network/Transport/QUIC/Internal/Server.hs +48/−0
- src/Network/Transport/QUIC/Internal/TLS.hs +13/−0
- test/Main.hs +16/−0
- test/Test/Network/Transport/QUIC.hs +112/−0
- test/Test/Network/Transport/QUIC/Internal/Messaging.hs +51/−0
- test/Test/Network/Transport/QUIC/Internal/QUICAddr.hs +45/−0
- test/credentials/cert.crt +22/−0
- test/credentials/cert.key +28/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@++2026-01-01 Laurent P. René de Cotret <laurent.decotret@outlook.com> 0.1.0++* Initial release.
+ LICENSE view
@@ -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.
+ bench/Bench.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Concurrent (forkIO)+import Control.Concurrent.Async (forConcurrently_)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (finally, throwIO)+import Control.Monad (forM_, replicateM, void, when)+import qualified Data.ByteString as BS+import Data.IORef (+ atomicModifyIORef',+ newIORef,+ )+import Data.List.NonEmpty (NonEmpty (..))+import Network.Transport (+ Connection (send),+ EndPoint (address, connect, receive),+ Event (ConnectionOpened, Received),+ Reliability (ReliableOrdered),+ Transport (closeTransport, newEndPoint),+ defaultConnectHints,+ )+import qualified Network.Transport.QUIC as QUIC+import qualified Network.Transport.TCP as TCP+import System.FilePath ((</>))+import Test.Tasty (TestTree)+import Test.Tasty.Bench (bench, bgroup, defaultMain, nfIO)++data TransportConfig = TransportConfig+ { transportName :: String+ , mkTransport :: IO Transport+ }++tcpConfig :: TransportConfig+tcpConfig =+ TransportConfig+ { transportName = "TCP"+ , mkTransport = do+ Right t <- TCP.createTransport (TCP.defaultTCPAddr "127.0.0.1" "0") TCP.defaultTCPParameters+ pure t+ }++quicConfig :: TransportConfig+quicConfig =+ TransportConfig+ { transportName = "QUIC"+ , mkTransport =+ 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 -> throwIO $ userError errmsg+ Right credentials ->+ QUIC.createTransport "127.0.0.1" "0" (credentials :| [])+ }++data BenchParams = BenchParams+ { messageSize :: !Int+ , messageCount :: !Int+ , connectionCount :: !Int+ }++smallMessages, mediumMessages, largeMessages :: BenchParams+smallMessages = BenchParams{messageSize = 64, messageCount = 10_000, connectionCount = 1}+mediumMessages = BenchParams{messageSize = 1024, messageCount = 1_000, connectionCount = 1}+largeMessages = BenchParams{messageSize = 4096, messageCount = 100, connectionCount = 1}++multiConn :: Int -> BenchParams -> BenchParams+multiConn n p = p{connectionCount = n}++throughputBench :: TransportConfig -> BenchParams -> IO ()+throughputBench TransportConfig{mkTransport} BenchParams{messageSize, messageCount, connectionCount} = do+ transport <- mkTransport+ flip finally (closeTransport transport) $ do+ Right senderEP <- newEndPoint transport+ Right receiverEP <- newEndPoint transport++ let payload = BS.replicate messageSize 0x42+ totalMessages = messageCount * connectionCount++ receiverReady <- newEmptyMVar+ receiverDone <- newEmptyMVar++ void $ forkIO $ do+ connsEstablished <- newIORef (0 :: Int)+ let waitForConnections = do+ event <- receive receiverEP+ case event of+ ConnectionOpened{} -> do+ n <- atomicModifyIORef' connsEstablished (\x -> (x + 1, x + 1))+ when (n < connectionCount) waitForConnections+ _ -> waitForConnections+ waitForConnections+ putMVar receiverReady ()++ msgsReceived <- newIORef (0 :: Int)+ let recvLoop = do+ event <- receive receiverEP+ case event of+ Received _ _ -> do+ n <- atomicModifyIORef' msgsReceived (\x -> (x + 1, x + 1))+ when (n < totalMessages) recvLoop+ _ -> recvLoop+ recvLoop+ putMVar receiverDone ()++ let receiverAddr = address receiverEP+ connections <-+ replicateM+ connectionCount+ ( connect senderEP receiverAddr ReliableOrdered defaultConnectHints >>= either throwIO pure+ )++ takeMVar receiverReady++ forConcurrently_ connections $ \conn ->+ forM_ [0 .. messageCount] $ \_ -> send conn [payload]++ takeMVar receiverDone++benchTransport :: TransportConfig -> TestTree+benchTransport cfg@TransportConfig{transportName} =+ bgroup+ transportName+ [ bgroup+ "throughput"+ [ bgroup+ "single-connection"+ [ bench "small-msg" $ nfIO $ throughputBench cfg smallMessages+ , bench "default-msg" $ nfIO $ throughputBench cfg mediumMessages+ , bench "large-msg" $ nfIO $ throughputBench cfg largeMessages+ ]+ , bgroup+ "multi-connection"+ [ bench "2-conn" $ nfIO $ throughputBench cfg smallMessages{connectionCount = 2, messageCount = 10_000}+ , bench "5-conn" $ nfIO $ throughputBench cfg smallMessages{connectionCount = 5, messageCount = 10_000}+ , bench "10-conn" $ nfIO $ throughputBench cfg smallMessages{connectionCount = 10, messageCount = 5_000}+ ]+ ]+ ]++main :: IO ()+main =+ defaultMain+ [ benchTransport tcpConfig+ , benchTransport quicConfig+ ]
+ network-transport-quic.cabal view
@@ -0,0 +1,110 @@+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.8 GHC==9.6.7 GHC==9.8.4 GHC==9.10.3 GHC==9.12.2+Category: Network+extra-doc-files: CHANGELOG.md+extra-source-files:+ test/credentials/cert.crt+ test/credentials/cert.key++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 >= 2.2 && <2.3+ , base >= 4.14 && < 5+ , binary >= 0.8 && < 0.10+ , bytestring >= 0.11 && < 0.13+ , containers >= 0.6 && <0.9+ , 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+ , tls >= 2.1 && < 2.2+ , tls-session-manager >= 0.0.5 && <0.1+ 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+ 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+ , network+ , network-transport+ , network-transport-quic+ , network-transport-tests+ , tasty ^>=1.5+ , tasty-flaky ^>= 0.1.3+ , tasty-hedgehog+ , tasty-hunit++benchmark network-transport-quic-bench+ import: common+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Bench.hs+ default-language: Haskell2010+ ghc-options: -rtsopts -with-rtsopts=-N+ build-depends: async+ , base >=4.14 && <5+ , bytestring+ , filepath+ , network-transport+ , network-transport-tcp+ , network-transport-quic+ , tasty ^>=1.5+ , tasty-bench >=0.4
+ src/Network/Transport/QUIC.hs view
@@ -0,0 +1,22 @@+module Network.Transport.QUIC+ ( -- * Main interface+ createTransport,++ -- ** Transport configuration+ QUICTransportConfig (..),+ defaultQUICTransportConfig,++ -- ** Re-export to generate credentials+ Credential,+ credentialLoadX509,+ )+where++import Network.Transport.QUIC.Internal+ ( -- \* Re-export to generate credentials+ Credential,+ createTransport,+ credentialLoadX509,+ defaultQUICTransportConfig,+ )+import Network.Transport.QUIC.Internal.QUICTransport (QUICTransportConfig (..))
+ src/Network/Transport/QUIC/Internal.hs view
@@ -0,0 +1,466 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Transport.QUIC.Internal+ ( createTransport,+ QUICTransportConfig (..),+ defaultQUICTransportConfig,+ 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 (ByteString, 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 Lens.Micro.Platform ((+~))+import Network.QUIC qualified as QUIC+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,+ QUICTransportConfig (..),+ RemoteEndPoint (..),+ RemoteEndPointState (..),+ TransportState (..),+ ValidRemoteEndPointState (..),+ closeLocalEndpoint,+ closeRemoteEndPoint,+ createConnectionTo,+ createRemoteEndPoint,+ defaultQUICTransportConfig,+ foldOpenEndPoints,+ localAddress,+ localEndPointState,+ localEndPoints,+ localQueue,+ newLocalEndPoint,+ newQUICTransport,+ nextSelfConnOutId,+ remoteEndPointAddress,+ remoteEndPointState,+ remoteIncoming,+ remoteServerConnId,+ remoteStream,+ transportConfig,+ 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 ::+ QUICTransportConfig ->+ IO Transport+createTransport initialConfig = do+ quicTransport <- newQUICTransport initialConfig++ let resolvedConfig = quicTransport ^. transportConfig+ serverThread <-+ forkServer+ (quicTransport ^. transportInputSocket)+ (credentials resolvedConfig)+ throwIO+ throwIO+ (handleNewStream quicTransport)++ pure $+ Transport+ { newEndPoint = newTQueueIO >>= newEndpoint quicTransport,+ 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++ (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 :: 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 = createConnectionId serverConnId++ 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+ pure (RemoteEndPointClosed, vst ^. remoteIncoming)+ other -> pure (other, Nothing)+ unless+ (isNothing connIds)+ ( atomically $+ forM_+ connIds+ (writeTQueue ourQueue . ConnectionClosed . connectionId)+ )++ handleMessage :: ClientConnId -> [ByteString] -> IO ()+ handleMessage clientConnId payload =+ atomically (writeTQueue ourQueue (Received (connectionId clientConnId) payload))++ prematureExit :: IOException -> IO ()+ prematureExit exc = do+ modifyMVar_ remoteState $ \case+ RemoteEndPointValid {} -> pure RemoteEndPointClosed+ RemoteEndPointInit -> pure RemoteEndPointClosed+ RemoteEndPointClosed -> pure RemoteEndPointClosed+ atomically+ ( writeTQueue+ ourQueue+ ( ErrorEvent+ ( TransportError+ (EventConnectionLost remoteAddress)+ (displayException exc)+ )+ )+ )++newEndpoint ::+ QUICTransport ->+ TQueue Event ->+ IO (Either (TransportError NewEndPointErrorCode) EndPoint)+newEndpoint quicTransport 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+ (credentials $ quicTransport ^. transportConfig)+ (validateCredentials $ quicTransport ^. transportConfig),+ 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 ->+ -- | Validate credentials+ Bool ->+ EndPointAddress ->+ Reliability ->+ ConnectHints ->+ IO (Either (TransportError ConnectErrorCode) Connection)+newConnection ourEndPoint creds validateCreds remoteAddress _reliability _connectHints =+ if ourAddress == remoteAddress+ then connectToSelf ourEndPoint+ else+ createConnectionTo creds validateCreds 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 ->+ 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) $ \case+ 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) $ \case+ LocalEndPointStateValid _ -> do+ alive <- readIORef connAlive+ when alive $ do+ atomically $ writeTQueue queue (ConnectionClosed connId)+ writeIORef connAlive False+ LocalEndPointStateClosed ->+ return ()
+ src/Network/Transport/QUIC/Internal/Client.hs view
@@ -0,0 +1,95 @@+{-# 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 ->+ -- | Validate credentials+ Bool ->+ -- | 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 validateCreds 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 validateCreds++ 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
+ src/Network/Transport/QUIC/Internal/Configuration.hs view
@@ -0,0 +1,46 @@+++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(ccValidate), ccPortName, ccServerName, defaultClientConfig)+import Network.QUIC.Internal (ServerConfig, ccCredentials)+import Network.QUIC.Server (ServerConfig (scCredentials, scSessionManager), 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 ->+ Bool -> -- ^ Validate credentials+ IO ClientConfig+mkClientConfig host port creds validate = do+ pure $+ defaultClientConfig+ { ccServerName = host+ , ccPortName = port+ , ccValidate = validate+ , ccCredentials = Credentials (NonEmpty.toList creds)+ }++mkServerConfig ::+ NonEmpty Credential ->+ IO ServerConfig+mkServerConfig creds = do+ tlsSessionManager <- TLS.sessionManager++ pure $+ defaultServerConfig+ { scSessionManager = tlsSessionManager+ , scCredentials = Credentials (NonEmpty.toList creds)+ }
+ src/Network/Transport/QUIC/Internal/Messaging.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}++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 (SomeException, catch, displayException, mask, throwIO, try)+import Control.Monad (replicateM)+import Data.Binary (Binary)+import Data.Binary qualified as Binary+import Data.Bits (shiftL, (.|.))+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+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.Internal (decodeWord32, encodeWord32)+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 ->+ [ByteString] ->+ IO (Either QUIC.QUICException ())+sendMessage stream connId messages =+ try+ ( QUIC.sendStreamMany+ stream+ (encodeMessage connId messages)+ )++-- | 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+ -- Note that 'recvStream' may return less bytes than requested.+ -- Therefore, we must wrap it in 'getAllBytes'.+ (getAllBytes (QUIC.recvStream stream))+ )+ `catch` (\(ex :: QUIC.QUICException) -> throwIO ex)++-- | Encode a message.+--+-- The encoding is composed of a header, and the payloads.+-- The message header is composed of:+-- 1. A control byte, to determine how the message should be parsed.+-- 2. A 32-bit word that encodes the endpoint ID of the destination endpoint;+-- 3. A 32-bit word that encodes the number of frames in the message+--+-- The payload frames are each prepended with the length of the frame.+encodeMessage ::+ ClientConnId ->+ [ByteString] ->+ [ByteString]+encodeMessage connId messages =+ BS.concat+ [ BS.singleton messageControlByte,+ encodeWord32 (fromIntegral connId),+ encodeWord32 (fromIntegral $ length messages)+ ]+ : [encodeWord32 (fromIntegral $ BS.length message) <> message | message <- messages]++decodeMessage ::+ (Int -> IO ByteString) ->+ IO (Either String MessageReceived)+decodeMessage get =+ get 1+ >>= maybe+ (pure $ Right StreamClosed)+ ( \controlByte ->+ go controlByte `catch` (\(ex :: SomeException) -> pure $ Left (displayException ex))+ ) . flip BS.indexMaybe 0+ where+ go ctrl+ | ctrl == closeEndPointControlByte = pure $ Right CloseEndPoint+ | ctrl == closeConnectionControlByte = Right . CloseConnection . fromIntegral <$> getWord32+ | ctrl == messageControlByte = do+ connId <- getWord32+ numMessages <- getWord32+ messages <- replicateM (fromIntegral numMessages) $ do+ getWord32 >>= get . fromIntegral+ pure . Right $ Message (fromIntegral connId) messages+ | otherwise = pure $ Left $ "Unsupported control byte: " <> show ctrl+ getWord32 = get 4 <&> decodeWord32++-- | Wrap a method to fetch bytes, to ensure that we always get exactly the+-- intended number of bytes.+getAllBytes ::+ -- | Function to fetch at most 'n' bytes+ (Int -> IO ByteString) ->+ -- | Function to fetch exactly 'n' bytes+ (Int -> IO ByteString)+getAllBytes get n = go n mempty+ where+ go 0 !acc = pure $ BS.concat acc+ go m !acc =+ get m >>= \bytes ->+ go+ (m - BS.length bytes)+ (acc <> [bytes])++data MessageReceived+ = Message+ {-# UNPACK #-} !ClientConnId+ {-# UNPACK #-} ![ByteString]+ | CloseConnection !ClientConnId+ | CloseEndPoint+ | StreamClosed+ deriving (Show, Eq)++newtype AckException = AckException String+ deriving (Show, Eq)++instance Exception AckException++ackMessage :: ByteString+ackMessage = BS.singleton connectionAcceptedControlByte++rejectMessage :: ByteString+rejectMessage = BS.singleton 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 received.+recvWord32 ::+ Stream ->+ IO (Either String Word32)+recvWord32 stream =+ mask $ \restore ->+ restore+ ( QUIC.recvStream stream 4 <&> Right . decodeWord32+ )+ `catch` (\(ex :: SomeException) -> pure $ Left (displayException 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+ ( BS.concat [BS.singleton closeConnectionControlByte, encodeWord32 (fromIntegral connId)]+ )+ )++-- | Send a message to close the connection.+sendCloseEndPoint :: Stream -> IO (Either QUIC.QUICException ())+sendCloseEndPoint stream =+ try+ ( QUIC.sendStream+ stream+ ( BS.singleton 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 = encodeWord32 $ fromIntegral (BS.length encodedPayload)++ try+ ( QUIC.sendStream+ stream+ (BS.concat [payloadLength, encodedPayload])+ )+ >>= \case+ Left (_exc :: SomeException) -> pure $ Left ()+ Right _ ->+ -- 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
+ src/Network/Transport/QUIC/Internal/QUICAddr.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.Transport.QUIC.Internal.QUICAddr (+ EndPointId (..),+ QUICAddr (..),+ encodeQUICAddr,+ decodeQUICAddr,+) where++import Data.Binary (Binary)+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Char8 qualified as BSC (unpack)+import Data.Word (Word32)+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, Read, 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 end point address+decodeQUICAddr ::+ EndPointAddress ->+ Either String QUICAddr+decodeQUICAddr (EndPointAddress bs) =+ case splitMaxFromEnd (== ':') 2 $ BSC.unpack bs of+ [host, port, endPointIdStr] ->+ case reads endPointIdStr of+ [(endPointId, "")] -> Right $ QUICAddr host port endPointId+ _ -> Left $ "Undecodeable 'EndPointAddress': " <> show bs+ _ ->+ Left $ "Undecodeable 'EndPointAddress': " <> show bs++{- | @spltiMaxFromEnd p n xs@ splits list @xs@ at elements matching @p@,+returning at most @p@ segments -- counting from the /end/++> splitMaxFromEnd (== ':') 2 "ab:cd:ef:gh" == ["ab:cd", "ef", "gh"]+-}+splitMaxFromEnd :: (a -> Bool) -> Int -> [a] -> [[a]]+splitMaxFromEnd p = \n -> go [[]] n . reverse+ where+ -- go :: [[a]] -> Int -> [a] -> [[a]]+ go accs _ [] = accs+ go ([] : accs) 0 xs = reverse xs : accs+ go (acc : accs) n (x : xs) =+ if p x+ then go ([] : acc : accs) (n - 1) xs+ else go ((x : acc) : accs) n xs+ go _ _ _ = error "Bug in splitMaxFromEnd"
+ src/Network/Transport/QUIC/Internal/QUICTransport.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Network.Transport.QUIC.Internal.QUICTransport+ ( -- * QUICTransport+ QUICTransport,+ newQUICTransport,+ foldOpenEndPoints,+ transportConfig,+ transportInputSocket,+ transportState,++ -- ** Configuration+ QUICTransportConfig (..),+ defaultQUICTransportConfig,++ -- * 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.+-}++-- | Represents the configuration used by the entire transport.+data QUICTransportConfig = QUICTransportConfig+ { -- | Host name, which can be an IP address or a domain name.+ hostName :: HostName,+ -- | Port or service name. The default is port 443.+ serviceName :: ServiceName,+ -- | At least one set of credentials is required.+ credentials :: NonEmpty Credential,+ -- | Note that if your credentials is self-signed, you will have+ -- to turn off 'validateCredentials'. This should only be set to 'False'+ -- in tests, or in a private network.+ validateCredentials :: Bool+ }+ deriving (Eq, Show)++defaultQUICTransportConfig :: HostName -> NonEmpty Credential -> QUICTransportConfig+defaultQUICTransportConfig host creds =+ QUICTransportConfig+ { hostName = host,+ serviceName = "443",+ credentials = creds,+ validateCredentials = True+ }++data QUICTransport = QUICTransport+ { _transportConfig :: QUICTransportConfig,+ _transportInputSocket :: Socket,+ _transportState :: MVar TransportState+ }++data TransportState+ = TransportStateValid ValidTransportState+ | TransportStateClosed++data ValidTransportState = ValidTransportState+ { _localEndPoints :: !(Map EndPointId LocalEndPoint),+ _nextEndPointId :: !EndPointId+ }++-- | Create a new QUICTransport+newQUICTransport :: QUICTransportConfig -> IO QUICTransport+newQUICTransport config = do+ addr <- NE.head <$> N.getAddrInfo (Just N.defaultHints) (Just (hostName config)) (Just (serviceName config))+ 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+ config{serviceName=show port}+ socket+ <$> newMVar (TransportStateValid $ ValidTransportState mempty 1)++data LocalEndPoint = OpenLocalEndPoint+ { _localAddress :: !EndPointAddress,+ _localEndPointId :: !EndPointId,+ _localEndPointState :: !(MVar LocalEndPointState),+ -- | Queue used to receive events+ _localQueue :: !(TQueue Event)+ }++-- | 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,+ -- | We identify connections by remote endpoint address, AND ConnectionCounter,+ -- to support multiple connections between the same two endpoint addresses+ _nextConnInId :: !ServerConnId,+ _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 _ _) = "<RemoteEndPoint @ " <> 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) $ \case+ 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+ (hostName $ quicTransport ^. transportConfig)+ (serviceName $ quicTransport ^. transportConfig)+ 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 (`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 ->+ -- | Validate credentials+ Bool ->+ LocalEndPoint ->+ EndPointAddress ->+ IO (Either (TransportError ConnectErrorCode) (RemoteEndPoint, ClientConnId))+createConnectionTo creds validateCreds localEndPoint remoteAddress = do+ createRemoteEndPoint localEndPoint remoteAddress Outgoing >>= \case+ Left err -> pure $ Left err+ Right (remoteEndPoint, _) ->+ streamToEndpoint+ creds+ validateCreds+ (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"
+ src/Network/Transport/QUIC/Internal/Server.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE ScopedTypeVariables #-}++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+ )
+ src/Network/Transport/QUIC/Internal/TLS.hs view
@@ -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
+ test/Main.hs view
@@ -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+ ]
+ test/Test/Network/Transport/QUIC.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Network.Transport.QUIC (tests) where++import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (bracket)+import Control.Monad (replicateM_)+import Data.ByteString qualified as BS+import Data.List.NonEmpty (NonEmpty (..))+import Network.Transport (EndPoint (..), Event (ConnectionClosed, ConnectionOpened, Received), Reliability (..), Transport (..), close, defaultConnectHints, send)+import Network.Transport.QUIC (QUICTransportConfig (..))+import Network.Transport.QUIC qualified as QUIC+import Network.Transport.Tests (echoServer)+import Network.Transport.Tests qualified as Tests+import Network.Transport.Tests.Auxiliary (forkTry)+import Network.Transport.Util (spawn)+import System.FilePath ((</>))+import System.Timeout (timeout)+import Test.Tasty (TestName, TestTree, testGroup)+import Test.Tasty.Flaky (flakyTest, limitRetries)+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))++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,+ flaky $ testCaseWithTimeout "closeReopen" $ withQUICTransport $ flip Tests.testCloseReopen 5,+ -- This test is flaky specifically in Github Actions+ flaky $ testCaseWithTimeout "parallelConnects" $ withQUICTransport $ flip Tests.testParallelConnects 5,+ testCaseWithTimeout "selfSend" $ withQUICTransport Tests.testSelfSend,+ flaky $ testCaseWithTimeout "closeTwice" $ withQUICTransport $ flip Tests.testCloseTwice 1,+ testCaseWithTimeout "connectToSelf" $ withQUICTransport $ flip Tests.testConnectToSelf 5,+ testCaseWithTimeout "connectToSelfTwice" $ withQUICTransport $ flip Tests.testConnectToSelfTwice 5,+ testCaseWithTimeout "closeSelf" $ withQUICTransport (Tests.testCloseSelf . pure . Right),+ flaky $ testCaseWithTimeout "closeEndPoint" $ withQUICTransport $ flip Tests.testCloseEndPoint 1,+ flaky $ testCaseWithTimeout "closeTransport" $ Tests.testCloseTransport mkQUICTransport,+ flaky $ testCaseWithTimeout "connectClosedEndPoint" $ withQUICTransport Tests.testConnectClosedEndPoint,+ flaky testSendVeryLargeMessages+ ]++flaky :: TestTree -> TestTree+flaky = flakyTest (limitRetries 3)++-- | 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 creds ->+ Right+ <$> QUIC.createTransport+ ( QUICTransportConfig+ { hostName = "127.0.0.1",+ serviceName = "0",+ credentials = creds :| [],+ -- credentials are self-signed+ validateCredentials = False+ }+ )++withQUICTransport :: (Transport -> IO a) -> IO a+withQUICTransport =+ bracket+ (mkQUICTransport >>= either assertFailure pure)+ closeTransport++testSendVeryLargeMessages :: TestTree+testSendVeryLargeMessages = testCase "Send very large messages" $ withQUICTransport $ \transport -> do+ server <- spawn transport echoServer+ result <- newEmptyMVar++ let numPings = 10+ let bigMessage = BS.replicate 4091 66 -- Using an odd number of bytes (4091) to test message boundaries+ _ <- forkTry $ do+ Right endpoint <- newEndPoint transport+ ping endpoint server numPings bigMessage+ putMVar result ()++ takeMVar result+ where+ ping endpoint serverAddr numPings message = do+ Right conn <- connect endpoint serverAddr ReliableOrdered defaultConnectHints++ ConnectionOpened cid _ _ <- receive endpoint++ replicateM_ numPings $ do+ _ <- send conn [message]+ Received cid' [reply] <- receive endpoint+ assertBool mempty $ cid == cid' && reply == message++ close conn++ receive endpoint >>= (@?=) (ConnectionClosed cid)
+ test/Test/Network/Transport/QUIC/Internal/Messaging.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Network.Transport.QUIC.Internal.Messaging (tests) where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.ByteString (ByteString)+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 4096)))+ let encoded = mconcat $ encodeMessage endpointId messages++ getBytes <- liftIO $ messageDecoder encoded++ decoded <- liftIO $ decodeMessage getBytes+ Right (Message endpointId messages) === decoded++messageDecoder :: ByteString -> IO (Int -> IO ByteString)+messageDecoder allBytes = do+ ref <- newIORef allBytes+ pure+ ( \nbytes -> do+ atomicModifyIORef+ ref+ ( \remainingBytes ->+ ( BS.drop nbytes remainingBytes+ , BS.take nbytes remainingBytes+ )+ )+ )
+ test/Test/Network/Transport/QUIC/Internal/QUICAddr.hs view
@@ -0,0 +1,45 @@+module Test.Network.Transport.QUIC.Internal.QUICAddr (tests) where++import Control.Monad (replicateM)+import Data.List (intercalate)+import Hedgehog (Gen, forAll, property, tripping)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+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 intercalate "." <$> replicateM 4 (show <$> fragment)++ genIPV6 :: Gen HostName+ genIPV6 =+ let fragment = Gen.word16 Range.constantBounded+ in intercalate ":" <$> replicateM 6 (show <$> fragment)++ genNamed :: Gen HostName+ genNamed =+ (\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
+ test/credentials/cert.crt view
@@ -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-----
+ test/credentials/cert.key view
@@ -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-----