diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Network/HTTP3/Client.hs b/Network/HTTP3/Client.hs --- a/Network/HTTP3/Client.hs +++ b/Network/HTTP3/Client.hs @@ -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 (..)) diff --git a/Network/QPACK.hs b/Network/QPACK.hs --- a/Network/QPACK.hs +++ b/Network/QPACK.hs @@ -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 () diff --git a/http3.cabal b/http3.cabal --- a/http3.cabal +++ b/http3.cabal @@ -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 @@ -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, diff --git a/util/ClientX.hs b/util/ClientX.hs --- a/util/ClientX.hs +++ b/util/ClientX.hs @@ -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 == "" diff --git a/util/ServerX.hs b/util/ServerX.hs --- a/util/ServerX.hs +++ b/util/ServerX.hs @@ -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 diff --git a/util/client.hs b/util/client.hs deleted file mode 100644 --- a/util/client.hs +++ /dev/null @@ -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}) "") - "directory to store qlog" - , Option - ['l'] - ["key-log-file"] - (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") - "a file to store negotiated secrets" - , Option - ['g'] - ["groups"] - (ReqArg (\gs o -> o{optGroups = Just gs}) "") - "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)}) "") - "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}) "") - "measure performance" - , Option - ['n'] - ["number-of-requests"] - (ReqArg (\n o -> o{optNumOfReqs = read 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 and \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 diff --git a/util/h3-client.hs b/util/h3-client.hs new file mode 100644 --- /dev/null +++ b/util/h3-client.hs @@ -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}) "") + "directory to store qlog" + , Option + ['l'] + ["key-log-file"] + (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") + "a file to store negotiated secrets" + , Option + ['g'] + ["groups"] + (ReqArg (\gs o -> o{optGroups = Just gs}) "") + "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)}) "") + "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}) "") + "measure performance" + , Option + ['n'] + ["number-of-requests"] + (ReqArg (\n o -> o{optNumOfReqs = read 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 diff --git a/util/h3-server.hs b/util/h3-server.hs new file mode 100644 --- /dev/null +++ b/util/h3-server.hs @@ -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}) "") + "directory to store a debug file" + , Option + ['q'] + ["qlog-dir"] + (ReqArg (\dir o -> o{optQLogDir = Just dir}) "") + "directory to store qlog" + , Option + ['l'] + ["key-log-file"] + (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") + "a file to store negotiated secrets" + , Option + ['g'] + ["groups"] + (ReqArg (\gs o -> o{optGroups = Just gs}) "") + "groups for key exchange" + , Option + ['c'] + ["cert"] + (ReqArg (\fl o -> o{optCertFile = fl}) "") + "certificate file" + , Option + ['k'] + ["key"] + (ReqArg (\fl o -> o{optKeyFile = fl}) "") + "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 and \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 diff --git a/util/qif.hs b/util/qif.hs --- a/util/qif.hs +++ b/util/qif.hs @@ -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 diff --git a/util/server.hs b/util/server.hs deleted file mode 100644 --- a/util/server.hs +++ /dev/null @@ -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}) "") - "directory to store a debug file" - , Option - ['q'] - ["qlog-dir"] - (ReqArg (\dir o -> o{optQLogDir = Just dir}) "") - "directory to store qlog" - , Option - ['l'] - ["key-log-file"] - (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") - "a file to store negotiated secrets" - , Option - ['g'] - ["groups"] - (ReqArg (\gs o -> o{optGroups = Just gs}) "") - "groups for key exchange" - , Option - ['c'] - ["cert"] - (ReqArg (\fl o -> o{optCertFile = fl}) "") - "certificate file" - , Option - ['k'] - ["key"] - (ReqArg (\fl o -> o{optKeyFile = fl}) "") - "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 and \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