diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ + +2026-01-01 Laurent P. René de Cotret 0.1.0 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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 + ] diff --git a/network-transport-quic.cabal b/network-transport-quic.cabal new file mode 100644 --- /dev/null +++ b/network-transport-quic.cabal @@ -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 diff --git a/src/Network/Transport/QUIC.hs b/src/Network/Transport/QUIC.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/QUIC.hs @@ -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 (..)) diff --git a/src/Network/Transport/QUIC/Internal.hs b/src/Network/Transport/QUIC/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/QUIC/Internal.hs @@ -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 () diff --git a/src/Network/Transport/QUIC/Internal/Client.hs b/src/Network/Transport/QUIC/Internal/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/QUIC/Internal/Client.hs @@ -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 diff --git a/src/Network/Transport/QUIC/Internal/Configuration.hs b/src/Network/Transport/QUIC/Internal/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/QUIC/Internal/Configuration.hs @@ -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) + } diff --git a/src/Network/Transport/QUIC/Internal/Messaging.hs b/src/Network/Transport/QUIC/Internal/Messaging.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/QUIC/Internal/Messaging.hs @@ -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 diff --git a/src/Network/Transport/QUIC/Internal/QUICAddr.hs b/src/Network/Transport/QUIC/Internal/QUICAddr.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/QUIC/Internal/QUICAddr.hs @@ -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" diff --git a/src/Network/Transport/QUIC/Internal/QUICTransport.hs b/src/Network/Transport/QUIC/Internal/QUICTransport.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/QUIC/Internal/QUICTransport.hs @@ -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 _ _) = " 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" diff --git a/src/Network/Transport/QUIC/Internal/Server.hs b/src/Network/Transport/QUIC/Internal/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/QUIC/Internal/Server.hs @@ -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 + ) diff --git a/src/Network/Transport/QUIC/Internal/TLS.hs b/src/Network/Transport/QUIC/Internal/TLS.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/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/test/Test/Network/Transport/QUIC.hs b/test/Test/Network/Transport/QUIC.hs new file mode 100644 --- /dev/null +++ b/test/Test/Network/Transport/QUIC.hs @@ -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) diff --git a/test/Test/Network/Transport/QUIC/Internal/Messaging.hs b/test/Test/Network/Transport/QUIC/Internal/Messaging.hs new file mode 100644 --- /dev/null +++ b/test/Test/Network/Transport/QUIC/Internal/Messaging.hs @@ -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 + ) + ) + ) diff --git a/test/Test/Network/Transport/QUIC/Internal/QUICAddr.hs b/test/Test/Network/Transport/QUIC/Internal/QUICAddr.hs new file mode 100644 --- /dev/null +++ b/test/Test/Network/Transport/QUIC/Internal/QUICAddr.hs @@ -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 diff --git a/test/credentials/cert.crt b/test/credentials/cert.crt new file mode 100644 --- /dev/null +++ b/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/test/credentials/cert.key b/test/credentials/cert.key new file mode 100644 --- /dev/null +++ b/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-----