http3 0.0.9 → 0.0.10
raw patch · 11 files changed
+751/−666 lines, 11 filesdep +asyncdep ~http2dep ~quicnew-component:exe:h3-clientnew-component:exe:h3-serverPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: async
Dependency ranges changed: http2, quic
API changes (from Hackage documentation)
- Network.HQ.Client: type Client a = forall b. () => Request -> Response -> IO b -> IO b -> Aux -> IO a
+ Network.HQ.Client: type Client a = SendRequest -> Aux -> IO a
+ Network.HTTP3.Client: data () => Aux
+ Network.HTTP3.Client: type Client a = SendRequest -> Aux -> IO a
- Network.HTTP3.Client: type Client a = forall b. () => Request -> Response -> IO b -> IO b -> Aux -> IO a
+ Network.HTTP3.Client: type SendRequest = forall r. () => Request -> Response -> IO r -> IO r
Files
- ChangeLog.md +5/−0
- Network/HTTP3/Client.hs +3/−1
- Network/QPACK.hs +30/−16
- http3.cabal +10/−8
- util/ClientX.hs +44/−26
- util/ServerX.hs +63/−13
- util/client.hs +0/−451
- util/h3-client.hs +447/−0
- util/h3-server.hs +147/−0
- util/qif.hs +2/−2
- util/server.hs +0/−149
ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for http3 +## 0.0.10++* Locking QPCK encoder+* Renaming util/{client,server} to util/{h3-client,h3-server}.+ ## 0.0.9 * Fixing the support for http2 v5.1.
Network/HTTP3/Client.hs view
@@ -19,6 +19,8 @@ -- * HTTP\/3 client Client,+ SendRequest,+ Aux, -- * Request Request,@@ -65,7 +67,7 @@ import Control.Concurrent import qualified Data.ByteString.Char8 as C8 import Data.IORef-import Network.HTTP2.Client (Authority, Client, Scheme)+import Network.HTTP2.Client (Authority, Client, Scheme, SendRequest) import qualified Network.HTTP2.Client as H2 import Network.HTTP2.Client.Internal (Aux (..), Request (..), Response (..)) import Network.HTTP2.Internal (InpObj (..))
Network/QPACK.hs view
@@ -45,6 +45,7 @@ mk, ) where +import Control.Concurrent import Control.Concurrent.STM import qualified Data.ByteString as B import Data.CaseInsensitive@@ -131,7 +132,18 @@ gcbuf2 <- mallocPlainForeignPtrBytes bufsiz2 gcbuf3 <- mallocPlainForeignPtrBytes bufsiz3 dyntbl <- newDynamicTableForEncoding ecDynamicTableSize- let enc = qpackEncoder encStrategy gcbuf1 bufsiz1 gcbuf2 bufsiz2 gcbuf3 bufsiz3 dyntbl+ lock <- newMVar ()+ let enc =+ qpackEncoder+ encStrategy+ gcbuf1+ bufsiz1+ gcbuf2+ bufsiz2+ gcbuf3+ bufsiz3+ dyntbl+ lock handler = decoderInstructionHandler dyntbl return (enc, handler) @@ -144,23 +156,25 @@ -> GCBuffer -> Int -> DynamicTable+ -> MVar () -> TokenHeaderList -> IO (EncodedFieldSection, EncodedEncoderInstruction)-qpackEncoder stgy gcbuf1 bufsiz1 gcbuf2 bufsiz2 gcbuf3 bufsiz3 dyntbl ts =- withForeignPtr gcbuf1 $ \buf1 ->- withForeignPtr gcbuf2 $ \buf2 ->- withForeignPtr gcbuf3 $ \buf3 -> do- wbuf1 <- newWriteBuffer buf1 bufsiz1- wbuf2 <- newWriteBuffer buf2 bufsiz2- wbuf3 <- newWriteBuffer buf3 bufsiz3- thl <- encodeTokenHeader wbuf1 wbuf3 stgy dyntbl ts -- fixme: leftover- when (thl /= []) $ stdoutLogger "qpackEncoder: leftover"- hb0 <- toByteString wbuf1- ins <- toByteString wbuf3- encodePrefix wbuf2 dyntbl- prefix <- toByteString wbuf2- let hb = prefix `B.append` hb0- return (hb, ins)+qpackEncoder stgy gcbuf1 bufsiz1 gcbuf2 bufsiz2 gcbuf3 bufsiz3 dyntbl lock ts =+ withMVar lock $ \_ ->+ withForeignPtr gcbuf1 $ \buf1 ->+ withForeignPtr gcbuf2 $ \buf2 ->+ withForeignPtr gcbuf3 $ \buf3 -> do+ wbuf1 <- newWriteBuffer buf1 bufsiz1+ wbuf2 <- newWriteBuffer buf2 bufsiz2+ wbuf3 <- newWriteBuffer buf3 bufsiz3+ thl <- encodeTokenHeader wbuf1 wbuf3 stgy dyntbl ts -- fixme: leftover+ when (thl /= []) $ stdoutLogger "qpackEncoder: leftover"+ hb0 <- toByteString wbuf1+ ins <- toByteString wbuf3+ encodePrefix wbuf2 dyntbl+ prefix <- toByteString wbuf2+ let hb = prefix `B.append` hb0+ return (hb, ins) decoderInstructionHandler :: DynamicTable -> (Int -> IO EncodedDecoderInstruction) -> IO ()
http3.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: http3-version: 0.0.9+version: 0.0.10 license: BSD-3-Clause license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -32,7 +32,7 @@ source-repository head type: git- location: git://github.com/kazu-yamamoto/http3+ location: http3://github.com/kazu-yamamoto/http3 flag devel description: Development commands@@ -81,18 +81,18 @@ bytestring, case-insensitive, containers,- http2 >=5.1 && <5.2,+ http2 >=5.1.4 && <5.2, http-types, network, network-byte-order,- quic >= 0.1.11 && < 0.2,+ quic >= 0.1.20 && < 0.2, sockaddr, stm, time-manager, unliftio -executable server- main-is: server.hs+executable h3-server+ main-is: h3-server.hs hs-source-dirs: util other-modules: Common@@ -105,6 +105,7 @@ base >=4.9 && <5, base16-bytestring, bytestring,+ crypton, filepath, http-types, http2,@@ -119,8 +120,8 @@ else buildable: False -executable client- main-is: client.hs+executable h3-client+ main-is: h3-client.hs hs-source-dirs: util other-modules: Common@@ -131,6 +132,7 @@ ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5,+ async, base16-bytestring, bytestring, filepath,
util/ClientX.hs view
@@ -1,12 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE Strict #-}-{-# LANGUAGE StrictData #-} -module ClientX where+module ClientX (+ Aux (..),+ Cli,+ clientHQ,+ clientH3,+) where import Control.Concurrent+import Control.Concurrent.Async import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8@@ -15,17 +19,23 @@ import qualified UnliftIO.Exception as E import qualified Network.HQ.Client as HQ+import Network.HTTP3.Client (+ Client,+ ClientConfig (..),+ Config,+ Path,+ SendRequest,+ ) import qualified Network.HTTP3.Client as H3 data Aux = Aux- { auxPath :: String- , auxAuthority :: String+ { auxAuthority :: String , auxDebug :: String -> IO () , auxShow :: ByteString -> IO () , auxCheckClose :: IO Bool } -type Cli = Aux -> Connection -> IO ()+type Cli = Aux -> [Path] -> Connection -> IO () clientHQ :: Int -> Cli clientHQ n = clientX n HQ.run@@ -35,32 +45,40 @@ clientX :: Int- -> (Connection -> H3.ClientConfig -> H3.Config -> H3.Client () -> IO ())+ -> (Connection -> ClientConfig -> Config -> Client () -> IO ()) -> Cli-clientX n0 run Aux{..} conn = E.bracket H3.allocSimpleConfig H3.freeSimpleConfig $ \conf -> run conn cliconf conf client+clientX n0 run aux@Aux{..} paths conn = E.bracket H3.allocSimpleConfig H3.freeSimpleConfig $ \conf ->+ run conn cliconf conf $ client aux n0 paths where- req =- H3.requestNoBody- methodGet- (C8.pack auxPath)- [("User-Agent", "HaskellQuic/0.0.0")] cliconf =- H3.ClientConfig+ ClientConfig { scheme = "https" , authority = auxAuthority }- client sendRequest _aux = loop n0- where- loop 0 = return ()- loop n = do- () <- sendRequest req $ \rsp -> do- auxDebug "GET"- auxShow "------------------------"- consume rsp- auxShow "------------------------"- when (n /= 1) $ do- threadDelay 100000- loop (n - 1)++client :: Aux -> Int -> [Path] -> Client ()+client aux n0 paths sendRequest _aux =+ foldr1 concurrently_ $+ map (client' aux n0 sendRequest) paths++client' :: Aux -> Int -> SendRequest -> Path -> IO ()+client' Aux{..} n0 sendRequest path = loop n0+ where+ req =+ H3.requestNoBody+ methodGet+ path+ [("User-Agent", "HaskellQuic/0.0.0")]+ loop 0 = return ()+ loop n = do+ () <- sendRequest req $ \rsp -> do+ auxDebug "GET"+ auxShow "------------------------"+ consume rsp+ auxShow "------------------------"+ when (n /= 1) $ do+ threadDelay 100000+ loop (n - 1) consume rsp = do bs <- H3.getResponseBodyChunk rsp if bs == ""
util/ServerX.hs view
@@ -1,13 +1,21 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE Strict #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TupleSections #-} -module ServerX where+module ServerX (+ serverHQ,+ serverH3,+)+where +import Control.Monad+import Crypto.Hash (Context, SHA1) -- crypton+import qualified Crypto.Hash as CH+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Builder (byteString)+import qualified Data.ByteString.Char8 as C8 import qualified Network.HQ.Server as HQ-import qualified Network.HTTP.Types as H+import Network.HTTP.Types+import Network.HTTP2.Server hiding (run) import qualified Network.HTTP3.Server as H3 import qualified UnliftIO.Exception as E @@ -22,10 +30,52 @@ serverX :: (Connection -> H3.Config -> H3.Server -> IO ()) -> Connection -> IO () serverX run conn = E.bracket H3.allocSimpleConfig H3.freeSimpleConfig $ \conf ->- run conn conf $ \_req _aux sendResponse -> do- let hdr =- [ ("Content-Type", "text/html; charset=utf-8")- , ("Server", "HaskellQuic/0.0.0")- ]- rsp = H3.responseBuilder H.ok200 hdr "Hello, world!"- sendResponse rsp []+ run conn conf server++server :: Server+server req _aux sendResponse = case requestMethod req of+ Just "GET"+ | requestPath req == Just "/" -> sendResponse responseHello []+ Just "POST" -> sendResponse (responseEcho req) []+ _ -> sendResponse response404 []++responseHello :: Response+responseHello = responseBuilder ok200 header body+ where+ header =+ [ ("Content-Type", "text/plain")+ , ("Server", "HaskellQuic/0.0.0")+ ]+ body = byteString "Hello, world!\n"++response404 :: Response+response404 = responseBuilder notFound404 header body+ where+ header =+ [ ("Content-Type", "text/plain")+ , ("Server", "HaskellQuic/0.0.0")+ ]+ body = byteString "Not found\n"++responseEcho :: Request -> Response+responseEcho req = setResponseTrailersMaker h2rsp maker+ where+ h2rsp = responseStreaming ok200 header streamingBody+ header = [("Content-Type", "text/plain")]+ streamingBody write _flush = loop+ where+ loop = do+ bs <- getRequestBodyChunk req+ unless (B.null bs) $ do+ void $ write $ byteString bs+ loop+ maker = trailersMaker (CH.hashInit :: Context SHA1)++-- Strictness is important for Context.+trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker+trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]+ where+ sha1 = C8.pack $ show $ CH.hashFinalize ctx+trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'+ where+ ctx' = CH.hashUpdate ctx bs
− util/client.hs
@@ -1,451 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE Strict #-}-{-# LANGUAGE StrictData #-}--module Main where--import Control.Concurrent-import Control.Monad-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as C8-import Data.UnixTime-import Data.Word-import Foreign.C.Types-import Network.TLS.QUIC-import System.Console.GetOpt-import System.Environment-import System.Exit-import System.IO-import Text.Printf-import qualified UnliftIO.Timeout as T--import ClientX-import Common-import Network.QUIC-import Network.QUIC.Client-import Network.QUIC.Internal hiding (RTT0)--data Options = Options- { optDebugLog :: Bool- , optShow :: Bool- , optQLogDir :: Maybe FilePath- , optKeyLogFile :: Maybe FilePath- , optGroups :: Maybe String- , optValidate :: Bool- , optHQ :: Bool- , optVerNego :: Bool- , optResumption :: Bool- , opt0RTT :: Bool- , optRetry :: Bool- , optQuantum :: Bool- , optInteractive :: Bool- , optMigration :: Maybe ConnectionControl- , optPacketSize :: Maybe Int- , optPerformance :: Word64- , optNumOfReqs :: Int- , optUnconSock :: Bool- }- deriving (Show)--defaultOptions :: Options-defaultOptions =- Options- { optDebugLog = False- , optShow = False- , optQLogDir = Nothing- , optKeyLogFile = Nothing- , optGroups = Nothing- , optHQ = False- , optValidate = False- , optVerNego = False- , optResumption = False- , opt0RTT = False- , optRetry = False- , optQuantum = False- , optInteractive = False- , optMigration = Nothing- , optPacketSize = Nothing- , optPerformance = 0- , optNumOfReqs = 1- , optUnconSock = True- }--usage :: String-usage = "Usage: client [OPTION] addr port"--options :: [OptDescr (Options -> Options)]-options =- [ Option- ['d']- ["debug"]- (NoArg (\o -> o{optDebugLog = True}))- "print debug info"- , Option- ['v']- ["show-content"]- (NoArg (\o -> o{optShow = True}))- "print downloaded content"- , Option- ['q']- ["qlog-dir"]- (ReqArg (\dir o -> o{optQLogDir = Just dir}) "<dir>")- "directory to store qlog"- , Option- ['l']- ["key-log-file"]- (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")- "a file to store negotiated secrets"- , Option- ['g']- ["groups"]- (ReqArg (\gs o -> o{optGroups = Just gs}) "<groups>")- "specify groups"- , Option- ['c']- ["validate"]- (NoArg (\o -> o{optValidate = True}))- "validate server's certificate"- , Option- ['r']- ["hq"]- (NoArg (\o -> o{optHQ = True}))- "prefer hq (HTTP/0.9)"- , Option- ['s']- ["packet-size"]- (ReqArg (\n o -> o{optPacketSize = Just (read n)}) "<size>")- "specify QUIC packet size (UDP payload size)"- , Option- ['i']- ["interactive"]- (NoArg (\o -> o{optInteractive = True}))- "prefer hq (HTTP/0.9)"- , Option- ['V']- ["vernego"]- (NoArg (\o -> o{optVerNego = True}))- "try version negotiation"- , Option- ['R']- ["resumption"]- (NoArg (\o -> o{optResumption = True}))- "try session resumption"- , Option- ['Z']- ["0rtt"]- (NoArg (\o -> o{opt0RTT = True}))- "try sending early data"- , Option- ['S']- ["stateless-retry"]- (NoArg (\o -> o{optRetry = True}))- "check stateless retry"- , Option- ['Q']- ["quantum"]- (NoArg (\o -> o{optQuantum = True}))- "try sending large Initials"- , Option- ['M']- ["change-server-cid"]- (NoArg (\o -> o{optMigration = Just ChangeServerCID}))- "use a new server CID"- , Option- ['N']- ["change-client-cid"]- (NoArg (\o -> o{optMigration = Just ChangeClientCID}))- "use a new client CID"- , Option- ['B']- ["nat-rebinding"]- (NoArg (\o -> o{optMigration = Just NATRebinding}))- "use a new local port"- , Option- ['A']- ["address-mobility"]- (NoArg (\o -> o{optMigration = Just ActiveMigration}))- "use a new address and a new server CID"- , Option- ['t']- ["performance"]- (ReqArg (\n o -> o{optPerformance = read n}) "<size>")- "measure performance"- , Option- ['n']- ["number-of-requests"]- (ReqArg (\n o -> o{optNumOfReqs = read n}) "<n>")- "specify the number of requests"- , Option- ['m']- ["use-connected-socket"]- (NoArg (\o -> o{optUnconSock = False}))- "use connected sockets instead of unconnected sockets"- ]--showUsageAndExit :: String -> IO a-showUsageAndExit msg = do- putStrLn msg- putStrLn $ usageInfo usage options- exitFailure--clientOpts :: [String] -> IO (Options, [String])-clientOpts argv =- case getOpt Permute options argv of- (o, n, []) -> return (foldl (flip id) defaultOptions o, n)- (_, _, errs) -> showUsageAndExit $ concat errs--main :: IO ()-main = do- args <- getArgs- (opts@Options{..}, ips) <- clientOpts args- let ipslen = length ips- when (ipslen /= 2 && ipslen /= 3) $- showUsageAndExit "cannot recognize <addr> and <port>\n"- cmvar <- newEmptyMVar- let path- | ipslen == 3 = ips !! 2- | otherwise = "/"- addr = head ips- port = head $ tail ips- ccalpn ver- | optPerformance /= 0 = return $ Just ["perf"]- | otherwise =- let (h3X, hqX) = makeProtos ver- protos- | optHQ = [hqX, h3X]- | otherwise = [h3X, hqX]- in return $ Just protos- gvers vers- | optVerNego = GreasingVersion : vers- | otherwise = vers- setTPQuantum params- | optQuantum =- let bs = BS.replicate 1200 0- in params{grease = Just bs}- | otherwise = params- cc0 = defaultClientConfig- cc =- cc0- { ccServerName = addr- , ccPortName = port- , ccALPN = ccalpn- , ccValidate = optValidate- , ccPacketSize = optPacketSize- , ccDebugLog = optDebugLog- , ccVersions = gvers $ ccVersions cc0- , ccParameters = setTPQuantum $ ccParameters cc0- , ccKeyLog = getLogger optKeyLogFile- , ccGroups = getGroups (ccGroups cc0) optGroups- , ccQLog = optQLogDir- , ccHooks =- defaultHooks- { onCloseCompleted = putMVar cmvar ()- }- , ccAutoMigration = optUnconSock- }- debug- | optDebugLog = putStrLn- | otherwise = \_ -> return ()- showContent- | optShow = C8.putStrLn- | otherwise = \_ -> return ()- aux =- Aux- { auxPath = path- , auxAuthority = addr- , auxDebug = debug- , auxShow = showContent- , auxCheckClose = do- mx <- T.timeout 1000000 $ takeMVar cmvar- case mx of- Nothing -> return False- _ -> return True- }- runClient cc opts aux--runClient :: ClientConfig -> Options -> Aux -> IO ()-runClient cc opts@Options{..} aux@Aux{..} = do- auxDebug "------------------------"- (info1, info2, res, mig, client') <- run cc $ \conn -> do- i1 <- getConnectionInfo conn- let client = case alpn i1 of- Just proto | "hq" `BS.isPrefixOf` proto -> clientHQ optNumOfReqs- _ -> clientH3 optNumOfReqs- m <- case optMigration of- Nothing -> return False- Just mtyp -> do- x <- controlConnection conn mtyp- auxDebug $ "Migration by " ++ show mtyp- return x- t1 <- getUnixTime- if optInteractive- then do- console aux client conn- else do- client aux conn- stats <- getConnectionStats conn- print stats- t2 <- getUnixTime- i2 <- getConnectionInfo conn- r <- getResumptionInfo conn- printThroughput t1 t2 stats- return (i1, i2, r, m, client)- if- | optVerNego -> do- putStrLn "Result: (V) version negotiation ... OK"- exitSuccess- | optQuantum -> do- putStrLn "Result: (Q) quantum ... OK"- exitSuccess- | optResumption -> do- if isResumptionPossible res- then do- info3 <- runClient2 cc opts aux res client'- if handshakeMode info3 == PreSharedKey- then do- putStrLn "Result: (R) TLS resumption ... OK"- exitSuccess- else do- putStrLn "Result: (R) TLS resumption ... NG"- exitFailure- else do- putStrLn "Result: (R) TLS resumption ... NG"- exitFailure- | opt0RTT -> do- if is0RTTPossible res- then do- info3 <- runClient2 cc opts aux res client'- if handshakeMode info3 == RTT0- then do- putStrLn "Result: (Z) 0-RTT ... OK"- exitSuccess- else do- putStrLn "Result: (Z) 0-RTT ... NG"- exitFailure- else do- putStrLn "Result: (Z) 0-RTT ... NG"- exitFailure- | optRetry -> do- if retry info1- then do- putStrLn "Result: (S) retry ... OK"- exitSuccess- else do- putStrLn "Result: (S) retry ... NG"- exitFailure- | otherwise -> case optMigration of- Just ChangeServerCID -> do- let changed = remoteCID info1 /= remoteCID info2- if mig && remoteCID info1 /= remoteCID info2- then do- putStrLn "Result: (M) change server CID ... OK"- exitSuccess- else do- putStrLn $ "Result: (M) change server CID ... NG " ++ show (mig, changed)- exitFailure- Just ChangeClientCID -> do- let changed = localCID info1 /= localCID info2- if mig && changed- then do- putStrLn "Result: (N) change client CID ... OK"- exitSuccess- else do- putStrLn $ "Result: (N) change client CID ... NG " ++ show (mig, changed)- exitFailure- Just NATRebinding -> do- putStrLn "Result: (B) NAT rebinding ... OK"- exitSuccess- Just ActiveMigration -> do- let changed = remoteCID info1 /= remoteCID info2- if mig && changed- then do- putStrLn "Result: (A) address mobility ... OK"- exitSuccess- else do- putStrLn $ "Result: (A) address mobility ... NG " ++ show (mig, changed)- exitFailure- Nothing -> do- putStrLn "Result: (H) handshake ... OK"- putStrLn "Result: (D) stream data ... OK"- closeCompleted <- auxCheckClose- when closeCompleted $ putStrLn "Result: (C) close completed ... OK"- case alpn info1 of- Nothing -> return ()- Just alpn ->- when ("h3" `BS.isPrefixOf` alpn) $- putStrLn "Result: (3) H3 transaction ... OK"- exitSuccess--runClient2- :: ClientConfig- -> Options- -> Aux- -> ResumptionInfo- -> Cli- -> IO ConnectionInfo-runClient2 cc Options{..} aux@Aux{..} res client = do- threadDelay 100000- auxDebug "<<<< next connection >>>>"- auxDebug "------------------------"- run cc' $ \conn -> do- void $ client aux conn- getConnectionInfo conn- where- cc' =- cc- { ccResumption = res- , ccUse0RTT = opt0RTT && is0RTTPossible res- }--printThroughput :: UnixTime -> UnixTime -> ConnectionStats -> IO ()-printThroughput t1 t2 ConnectionStats{..} =- printf- "Throughput %.2f Mbps (%d bytes in %d msecs)\n"- bytesPerSeconds- rxBytes- millisecs- where- UnixDiffTime (CTime s) u = t2 `diffUnixTime` t1- millisecs :: Int- millisecs = fromIntegral s * 1000 + fromIntegral u `div` 1000- bytesPerSeconds :: Double- bytesPerSeconds =- fromIntegral rxBytes- * (1000 :: Double)- * 8- / fromIntegral millisecs- / 1024- / 1024--console :: Aux -> (Aux -> Connection -> IO ()) -> Connection -> IO ()-console aux client conn = do- waitEstablished conn- putStrLn "q -- quit"- putStrLn "g -- get"- putStrLn "p -- ping"- putStrLn "n -- NAT rebinding"- loop- where- loop = do- hSetBuffering stdout NoBuffering- putStr "> "- hSetBuffering stdout LineBuffering- l <- getLine- case l of- "q" -> putStrLn "bye"- "g" -> do- putStrLn $ "GET " ++ auxPath aux- _ <- forkIO $ client aux conn- loop- "p" -> do- putStrLn "Ping"- sendFrames conn RTT1Level [Ping]- loop- "n" -> do- controlConnection conn NATRebinding >>= print- loop- _ -> do- putStrLn "No such command"- loop
+ util/h3-client.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Concurrent+import Control.Monad+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import Data.UnixTime+import Data.Word+import Foreign.C.Types+import qualified Network.HTTP3.Client as H3+import Network.TLS.QUIC+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO+import Text.Printf+import qualified UnliftIO.Timeout as T++import ClientX+import Common+import Network.QUIC+import Network.QUIC.Client+import Network.QUIC.Internal hiding (RTT0)++data Options = Options+ { optDebugLog :: Bool+ , optShow :: Bool+ , optQLogDir :: Maybe FilePath+ , optKeyLogFile :: Maybe FilePath+ , optGroups :: Maybe String+ , optValidate :: Bool+ , optHQ :: Bool+ , optVerNego :: Bool+ , optResumption :: Bool+ , opt0RTT :: Bool+ , optRetry :: Bool+ , optQuantum :: Bool+ , optInteractive :: Bool+ , optMigration :: Maybe ConnectionControl+ , optPacketSize :: Maybe Int+ , optPerformance :: Word64+ , optNumOfReqs :: Int+ , optUnconSock :: Bool+ }+ deriving (Show)++defaultOptions :: Options+defaultOptions =+ Options+ { optDebugLog = False+ , optShow = False+ , optQLogDir = Nothing+ , optKeyLogFile = Nothing+ , optGroups = Nothing+ , optHQ = False+ , optValidate = False+ , optVerNego = False+ , optResumption = False+ , opt0RTT = False+ , optRetry = False+ , optQuantum = False+ , optInteractive = False+ , optMigration = Nothing+ , optPacketSize = Nothing+ , optPerformance = 0+ , optNumOfReqs = 1+ , optUnconSock = True+ }++usage :: String+usage = "Usage: h3-client [OPTION] addr port [path]"++options :: [OptDescr (Options -> Options)]+options =+ [ Option+ ['d']+ ["debug"]+ (NoArg (\o -> o{optDebugLog = True}))+ "print debug info"+ , Option+ ['v']+ ["show-content"]+ (NoArg (\o -> o{optShow = True}))+ "print downloaded content"+ , Option+ ['q']+ ["qlog-dir"]+ (ReqArg (\dir o -> o{optQLogDir = Just dir}) "<dir>")+ "directory to store qlog"+ , Option+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets"+ , Option+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = Just gs}) "<groups>")+ "specify groups"+ , Option+ ['e']+ ["validate"]+ (NoArg (\o -> o{optValidate = True}))+ "validate server's certificate"+ , Option+ ['9']+ ["hq"]+ (NoArg (\o -> o{optHQ = True}))+ "prefer hq (HTTP/0.9)"+ , Option+ ['s']+ ["packet-size"]+ (ReqArg (\n o -> o{optPacketSize = Just (read n)}) "<size>")+ "specify QUIC packet size (UDP payload size)"+ , Option+ ['i']+ ["interactive"]+ (NoArg (\o -> o{optInteractive = True}))+ "enter interactive mode"+ , Option+ ['V']+ ["vernego"]+ (NoArg (\o -> o{optVerNego = True}))+ "try version negotiation"+ , Option+ ['R']+ ["resumption"]+ (NoArg (\o -> o{optResumption = True}))+ "try session resumption"+ , Option+ ['Z']+ ["0rtt"]+ (NoArg (\o -> o{opt0RTT = True}))+ "try sending early data"+ , Option+ ['S']+ ["stateless-retry"]+ (NoArg (\o -> o{optRetry = True}))+ "check stateless retry"+ , Option+ ['Q']+ ["quantum"]+ (NoArg (\o -> o{optQuantum = True}))+ "try sending large Initials"+ , Option+ ['M']+ ["change-server-cid"]+ (NoArg (\o -> o{optMigration = Just ChangeServerCID}))+ "use a new server CID"+ , Option+ ['N']+ ["change-client-cid"]+ (NoArg (\o -> o{optMigration = Just ChangeClientCID}))+ "use a new client CID"+ , Option+ ['B']+ ["nat-rebinding"]+ (NoArg (\o -> o{optMigration = Just NATRebinding}))+ "use a new local port"+ , Option+ ['A']+ ["address-mobility"]+ (NoArg (\o -> o{optMigration = Just ActiveMigration}))+ "use a new address and a new server CID"+ , Option+ ['t']+ ["performance"]+ (ReqArg (\n o -> o{optPerformance = read n}) "<size>")+ "measure performance"+ , Option+ ['n']+ ["number-of-requests"]+ (ReqArg (\n o -> o{optNumOfReqs = read n}) "<n>")+ "specify the number of requests"+ , Option+ ['m']+ ["use-connected-socket"]+ (NoArg (\o -> o{optUnconSock = False}))+ "use connected sockets instead of unconnected sockets"+ ]++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ exitFailure++clientOpts :: [String] -> IO (Options, [String])+clientOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++main :: IO ()+main = do+ args <- getArgs+ (opts@Options{..}, ips) <- clientOpts args+ (host, port, paths) <- case ips of+ [] -> showUsageAndExit usage+ _ : [] -> showUsageAndExit usage+ h : p : [] -> return (h, p, ["/"])+ h : p : ps -> return (h, p, C8.pack <$> ps)+ cmvar <- newEmptyMVar+ let ccalpn ver+ | optPerformance /= 0 = return $ Just ["perf"]+ | otherwise =+ let (h3X, hqX) = makeProtos ver+ protos+ | optHQ = [hqX, h3X]+ | otherwise = [h3X, hqX]+ in return $ Just protos+ gvers vers+ | optVerNego = GreasingVersion : vers+ | otherwise = vers+ setTPQuantum params+ | optQuantum =+ let bs = BS.replicate 1200 0+ in params{grease = Just bs}+ | otherwise = params+ cc0 = defaultClientConfig+ cc =+ cc0+ { ccServerName = host+ , ccPortName = port+ , ccALPN = ccalpn+ , ccValidate = optValidate+ , ccPacketSize = optPacketSize+ , ccDebugLog = optDebugLog+ , ccVersions = gvers $ ccVersions cc0+ , ccParameters = setTPQuantum $ ccParameters cc0+ , ccKeyLog = getLogger optKeyLogFile+ , ccGroups = getGroups (ccGroups cc0) optGroups+ , ccQLog = optQLogDir+ , ccHooks =+ defaultHooks+ { onCloseCompleted = putMVar cmvar ()+ }+ , ccAutoMigration = optUnconSock+ }+ debug+ | optDebugLog = putStrLn+ | otherwise = \_ -> return ()+ showContent+ | optShow = C8.putStrLn+ | otherwise = \_ -> return ()+ aux =+ Aux+ { auxAuthority = host+ , auxDebug = debug+ , auxShow = showContent+ , auxCheckClose = do+ mx <- T.timeout 1000000 $ takeMVar cmvar+ case mx of+ Nothing -> return False+ _ -> return True+ }+ runClient cc opts aux paths++runClient :: ClientConfig -> Options -> Aux -> [H3.Path] -> IO ()+runClient cc opts@Options{..} aux@Aux{..} paths = do+ auxDebug "------------------------"+ (info1, info2, res, mig, client') <- run cc $ \conn -> do+ i1 <- getConnectionInfo conn+ let client = case alpn i1 of+ Just proto | "hq" `BS.isPrefixOf` proto -> clientHQ optNumOfReqs+ _ -> clientH3 optNumOfReqs+ m <- case optMigration of+ Nothing -> return False+ Just mtyp -> do+ x <- controlConnection conn mtyp+ auxDebug $ "Migration by " ++ show mtyp+ return x+ t1 <- getUnixTime+ if optInteractive+ then do+ console aux paths client conn+ else do+ client aux paths conn+ stats <- getConnectionStats conn+ print stats+ t2 <- getUnixTime+ i2 <- getConnectionInfo conn+ r <- getResumptionInfo conn+ printThroughput t1 t2 stats+ return (i1, i2, r, m, client)+ if+ | optVerNego -> do+ putStrLn "Result: (V) version negotiation ... OK"+ exitSuccess+ | optQuantum -> do+ putStrLn "Result: (Q) quantum ... OK"+ exitSuccess+ | optResumption -> do+ if isResumptionPossible res+ then do+ info3 <- runClient2 cc opts aux paths res client'+ if handshakeMode info3 == PreSharedKey+ then do+ putStrLn "Result: (R) TLS resumption ... OK"+ exitSuccess+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ | opt0RTT -> do+ if is0RTTPossible res+ then do+ info3 <- runClient2 cc opts aux paths res client'+ if handshakeMode info3 == RTT0+ then do+ putStrLn "Result: (Z) 0-RTT ... OK"+ exitSuccess+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ | optRetry -> do+ if retry info1+ then do+ putStrLn "Result: (S) retry ... OK"+ exitSuccess+ else do+ putStrLn "Result: (S) retry ... NG"+ exitFailure+ | otherwise -> case optMigration of+ Just ChangeServerCID -> do+ let changed = remoteCID info1 /= remoteCID info2+ if mig && remoteCID info1 /= remoteCID info2+ then do+ putStrLn "Result: (M) change server CID ... OK"+ exitSuccess+ else do+ putStrLn $ "Result: (M) change server CID ... NG " ++ show (mig, changed)+ exitFailure+ Just ChangeClientCID -> do+ let changed = localCID info1 /= localCID info2+ if mig && changed+ then do+ putStrLn "Result: (N) change client CID ... OK"+ exitSuccess+ else do+ putStrLn $ "Result: (N) change client CID ... NG " ++ show (mig, changed)+ exitFailure+ Just NATRebinding -> do+ putStrLn "Result: (B) NAT rebinding ... OK"+ exitSuccess+ Just ActiveMigration -> do+ let changed = remoteCID info1 /= remoteCID info2+ if mig && changed+ then do+ putStrLn "Result: (A) address mobility ... OK"+ exitSuccess+ else do+ putStrLn $ "Result: (A) address mobility ... NG " ++ show (mig, changed)+ exitFailure+ Nothing -> do+ putStrLn "Result: (H) handshake ... OK"+ putStrLn "Result: (D) stream data ... OK"+ closeCompleted <- auxCheckClose+ when closeCompleted $ putStrLn "Result: (C) close completed ... OK"+ case alpn info1 of+ Nothing -> return ()+ Just alpn ->+ when ("h3" `BS.isPrefixOf` alpn) $+ putStrLn "Result: (3) H3 transaction ... OK"+ exitSuccess++runClient2+ :: ClientConfig+ -> Options+ -> Aux+ -> [H3.Path]+ -> ResumptionInfo+ -> Cli+ -> IO ConnectionInfo+runClient2 cc Options{..} aux@Aux{..} paths res client = do+ threadDelay 100000+ auxDebug "<<<< next connection >>>>"+ auxDebug "------------------------"+ run cc' $ \conn -> do+ void $ client aux paths conn+ getConnectionInfo conn+ where+ cc' =+ cc+ { ccResumption = res+ , ccUse0RTT = opt0RTT && is0RTTPossible res+ }++printThroughput :: UnixTime -> UnixTime -> ConnectionStats -> IO ()+printThroughput t1 t2 ConnectionStats{..} =+ printf+ "Throughput %.2f Mbps (%d bytes in %d msecs)\n"+ bytesPerSeconds+ rxBytes+ millisecs+ where+ UnixDiffTime (CTime s) u = t2 `diffUnixTime` t1+ millisecs :: Int+ millisecs = fromIntegral s * 1000 + fromIntegral u `div` 1000+ bytesPerSeconds :: Double+ bytesPerSeconds =+ fromIntegral rxBytes+ * (1000 :: Double)+ * 8+ / fromIntegral millisecs+ / 1024+ / 1024++console :: Aux -> [H3.Path] -> Cli -> Connection -> IO ()+console aux paths client conn = do+ waitEstablished conn+ putStrLn "q -- quit"+ putStrLn "g -- get"+ putStrLn "p -- ping"+ putStrLn "n -- NAT rebinding"+ loop+ where+ loop = do+ hSetBuffering stdout NoBuffering+ putStr "> "+ hSetBuffering stdout LineBuffering+ l <- getLine+ case l of+ "q" -> putStrLn "bye"+ "g" -> do+ mapM_ (\p -> putStrLn $ "GET " ++ C8.unpack p) paths+ _ <- forkIO $ client aux paths conn+ loop+ "p" -> do+ putStrLn "Ping"+ sendFrames conn RTT1Level [Ping]+ loop+ "n" -> do+ controlConnection conn NATRebinding >>= print+ loop+ _ -> do+ putStrLn "No such command"+ loop
+ util/h3-server.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++module Main where++import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.List as L+import Network.TLS (Credentials (..), credentialLoadX509)+import qualified Network.TLS.SessionManager as SM+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit+import System.IO++import Common+import Network.QUIC+import Network.QUIC.Internal+import Network.QUIC.Server+import ServerX++data Options = Options+ { optDebugLogDir :: Maybe FilePath+ , optQLogDir :: Maybe FilePath+ , optKeyLogFile :: Maybe FilePath+ , optGroups :: Maybe String+ , optCertFile :: FilePath+ , optKeyFile :: FilePath+ , optRetry :: Bool+ }+ deriving (Show)++defaultOptions :: Options+defaultOptions =+ Options+ { optDebugLogDir = Nothing+ , optQLogDir = Nothing+ , optKeyLogFile = Nothing+ , optGroups = Nothing+ , optCertFile = "servercert.pem"+ , optKeyFile = "serverkey.pem"+ , optRetry = False+ }++options :: [OptDescr (Options -> Options)]+options =+ [ Option+ ['d']+ ["debug-log-dir"]+ (ReqArg (\dir o -> o{optDebugLogDir = Just dir}) "<dir>")+ "directory to store a debug file"+ , Option+ ['q']+ ["qlog-dir"]+ (ReqArg (\dir o -> o{optQLogDir = Just dir}) "<dir>")+ "directory to store qlog"+ , Option+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets"+ , Option+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = Just gs}) "<groups>")+ "groups for key exchange"+ , Option+ ['c']+ ["cert"]+ (ReqArg (\fl o -> o{optCertFile = fl}) "<file>")+ "certificate file"+ , Option+ ['k']+ ["key"]+ (ReqArg (\fl o -> o{optKeyFile = fl}) "<file>")+ "key file"+ , Option+ ['S']+ ["retry"]+ (NoArg (\o -> o{optRetry = True}))+ "require stateless retry"+ ]++usage :: String+usage = "Usage: h3-server [OPTION] addr [addrs] port"++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ exitFailure++serverOpts :: [String] -> IO (Options, [String])+serverOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++chooseALPN :: Version -> [ByteString] -> IO ByteString+chooseALPN _ protos+ | "perf" `elem` protos = return "perf"+chooseALPN ver protos = return $ case mh3idx of+ Nothing -> case mhqidx of+ Nothing -> ""+ Just _ -> hqX+ Just h3idx -> case mhqidx of+ Nothing -> h3X+ Just hqidx -> if h3idx < hqidx then h3X else hqX+ where+ (h3X, hqX) = makeProtos ver+ mh3idx = h3X `L.elemIndex` protos+ mhqidx = hqX `L.elemIndex` protos++main :: IO ()+main = do+ hSetBuffering stdout NoBuffering+ args <- getArgs+ (Options{..}, ips) <- serverOpts args+ when (length ips < 2) $ showUsageAndExit "cannot recognize <addr> and <port>\n"+ let port = read (last ips)+ addrs = read <$> init ips+ aps = (,port) <$> addrs+ smgr <- SM.newSessionManager SM.defaultConfig+ Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile+ let sc0 = defaultServerConfig+ sc =+ sc0+ { scAddresses = aps+ , scALPN = Just chooseALPN+ , scRequireRetry = optRetry+ , scSessionManager = smgr+ , scUse0RTT = True+ , scDebugLog = optDebugLogDir+ , scKeyLog = getLogger optKeyLogFile+ , scGroups = getGroups (scGroups sc0) optGroups+ , scQLog = optQLogDir+ , scCredentials = Credentials [cred]+ }+ run sc $ \conn -> do+ info <- getConnectionInfo conn+ let server = case alpn info of+ Just proto | "hq" `BS.isPrefixOf` proto -> serverHQ+ _ -> serverH3+ server conn
util/qif.hs view
@@ -96,7 +96,7 @@ where loop = do hdr' <- fromCaseSensitive <$> headerlist h- if hdr' == []+ if null hdr' then putMVar mvar () else do Block n bs <- recv@@ -124,7 +124,7 @@ return $ Block num dat toInt :: ByteString -> Int-toInt bs = BS.foldl' f 0 bs+toInt = BS.foldl' f 0 where f n w8 = n * 256 + fromIntegral w8
− util/server.hs
@@ -1,149 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE Strict #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TupleSections #-}--module Main where--import Control.Monad-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.List as L-import Network.TLS (Credentials (..), credentialLoadX509)-import qualified Network.TLS.SessionManager as SM-import System.Console.GetOpt-import System.Environment (getArgs)-import System.Exit-import System.IO--import Common-import Network.QUIC-import Network.QUIC.Internal-import Network.QUIC.Server-import ServerX--data Options = Options- { optDebugLogDir :: Maybe FilePath- , optQLogDir :: Maybe FilePath- , optKeyLogFile :: Maybe FilePath- , optGroups :: Maybe String- , optCertFile :: FilePath- , optKeyFile :: FilePath- , optRetry :: Bool- }- deriving (Show)--defaultOptions :: Options-defaultOptions =- Options- { optDebugLogDir = Nothing- , optQLogDir = Nothing- , optKeyLogFile = Nothing- , optGroups = Nothing- , optCertFile = "servercert.pem"- , optKeyFile = "serverkey.pem"- , optRetry = False- }--options :: [OptDescr (Options -> Options)]-options =- [ Option- ['d']- ["debug-log-dir"]- (ReqArg (\dir o -> o{optDebugLogDir = Just dir}) "<dir>")- "directory to store a debug file"- , Option- ['q']- ["qlog-dir"]- (ReqArg (\dir o -> o{optQLogDir = Just dir}) "<dir>")- "directory to store qlog"- , Option- ['l']- ["key-log-file"]- (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")- "a file to store negotiated secrets"- , Option- ['g']- ["groups"]- (ReqArg (\gs o -> o{optGroups = Just gs}) "<groups>")- "groups for key exchange"- , Option- ['c']- ["cert"]- (ReqArg (\fl o -> o{optCertFile = fl}) "<file>")- "certificate file"- , Option- ['k']- ["key"]- (ReqArg (\fl o -> o{optKeyFile = fl}) "<file>")- "key file"- , Option- ['S']- ["retry"]- (NoArg (\o -> o{optRetry = True}))- "require stateless retry"- ]--usage :: String-usage = "Usage: server [OPTION] addr [addrs] port"--showUsageAndExit :: String -> IO a-showUsageAndExit msg = do- putStrLn msg- putStrLn $ usageInfo usage options- exitFailure--serverOpts :: [String] -> IO (Options, [String])-serverOpts argv =- case getOpt Permute options argv of- (o, n, []) -> return (foldl (flip id) defaultOptions o, n)- (_, _, errs) -> showUsageAndExit $ concat errs--chooseALPN :: Version -> [ByteString] -> IO ByteString-chooseALPN _ protos- | "perf" `elem` protos = return "perf"-chooseALPN ver protos = return $ case mh3idx of- Nothing -> case mhqidx of- Nothing -> ""- Just _ -> hqX- Just h3idx -> case mhqidx of- Nothing -> h3X- Just hqidx -> if h3idx < hqidx then h3X else hqX- where- (h3X, hqX) = makeProtos ver- mh3idx = h3X `L.elemIndex` protos- mhqidx = hqX `L.elemIndex` protos--main :: IO ()-main = do- hSetBuffering stdout NoBuffering- args <- getArgs- (Options{..}, ips) <- serverOpts args- when (length ips < 2) $ showUsageAndExit "cannot recognize <addr> and <port>\n"- let port = read (last ips)- addrs = read <$> init ips- aps = (,port) <$> addrs- smgr <- SM.newSessionManager SM.defaultConfig- Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile- let sc0 = defaultServerConfig- sc =- sc0- { scAddresses = aps- , scALPN = Just chooseALPN- , scRequireRetry = optRetry- , scSessionManager = smgr- , scUse0RTT = True- , scDebugLog = optDebugLogDir- , scKeyLog = getLogger optKeyLogFile- , scGroups = getGroups (scGroups sc0) optGroups- , scQLog = optQLogDir- , scCredentials = Credentials [cred]- }- run sc $ \conn -> do- info <- getConnectionInfo conn- let server = case alpn info of- Just proto | "hq" `BS.isPrefixOf` proto -> serverHQ- _ -> serverH3- server conn