New network transport library based on QUIC

packages/network-transport-quic/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) Laurent P. René de Cotret
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

packages/network-transport-quic/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
+    ]

packages/network-transport-quic/network-transport-quic.cabal

@@ -0,0 +1,108 @@
+cabal-version: 3.0
+Name:          network-transport-quic
+Version:       0.1.0
+build-Type:    Simple
+License:       BSD-3-Clause
+License-file:  LICENSE
+Copyright:     Laurent P. René de Cotret
+Author:        Laurent P. René de Cotret
+maintainer:    The Distributed Haskell team
+Stability:     experimental
+Homepage:      http://haskell-distributed.github.com
+Bug-Reports:   https://github.com/haskell-distributed/distributed-process/issues
+Synopsis:      Networking layer for Cloud Haskell based on QUIC
+Description:   Networking layer for Cloud Haskell based on QUIC
+tested-with:   GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 GHC==9.12.1
+Category:      Network
+extra-doc-files: ChangeLog
+extra-source-files: test/credentials/*
+
+source-repository head
+  Type:     git
+  Location: https://github.com/haskell-distributed/distributed-process
+  SubDir:   packages/network-transport-quic
+
+common common
+    ghc-options:
+                 -- warnings
+                 -Wall
+                 -Wcompat
+                 -Widentities
+                 -Wincomplete-uni-patterns
+                 -Wincomplete-record-updates
+                 -Wredundant-constraints
+                 -fhide-source-paths
+                 -Wpartial-fields
+                 -Wunused-packages
+                 -- The -threaded option is /required/ to use the quic library
+                 -threaded
+
+library
+  import:             common
+  build-depends:      async
+                    , base >= 4.14 && < 5
+                    , binary >= 0.8 && < 0.10
+                    , bytestring >= 0.11 && < 0.13
+                    , containers
+                    , 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
+                    , tls-session-manager
+  exposed-modules:    Network.Transport.QUIC
+                      Network.Transport.QUIC.Internal
+  other-modules:      Network.Transport.QUIC.Internal.Configuration
+                      Network.Transport.QUIC.Internal.Client
+                      Network.Transport.QUIC.Internal.Messaging
+                      Network.Transport.QUIC.Internal.QUICAddr
+                      Network.Transport.QUIC.Internal.QUICTransport
+                      Network.Transport.QUIC.Internal.Server
+                      Network.Transport.QUIC.Internal.TLS
+  default-language:   Haskell2010
+  default-extensions: ImportQualifiedPost
+  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

packages/network-transport-quic/src/Network/Transport/QUIC.hs

@@ -0,0 +1,16 @@
+module Network.Transport.QUIC (
+    createTransport,
+    QUICAddr (..),
+
+    -- * Re-export to generate credentials
+    Credential,
+    credentialLoadX509,
+) where
+
+import Network.Transport.QUIC.Internal (
+    -- \* Re-export to generate credentials
+    Credential,
+    QUICAddr (..),
+    createTransport,
+    credentialLoadX509,
+ )