diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for http3 +## 0.1.2 + +* Updating dependencies. + ## 0.1.1 * Removing a debug logging to stdout. diff --git a/Network/HQ/Client.hs b/Network/HQ/Client.hs --- a/Network/HQ/Client.hs +++ b/Network/HQ/Client.hs @@ -42,7 +42,7 @@ import Network.HTTP.Semantics.Client.Internal import Network.QUIC (Connection) import qualified Network.QUIC as QUIC -import Network.QUIC.Internal (possibleMyStreams) +import qualified Network.QUIC.Internal as QUIC import Imports import qualified Network.HTTP3.Client as H3 @@ -53,8 +53,9 @@ run conn _ _ client = client (sendRequest conn) aux where aux = - Aux - { auxPossibleClientStreams = possibleMyStreams conn + defaultAux + { auxPossibleClientStreams = QUIC.possibleMyStreams conn + , auxSendPing = QUIC.sendFrames conn QUIC.RTT1Level [QUIC.Ping] } sendRequest :: Connection -> Request -> (Response -> IO a) -> IO a diff --git a/Network/HQ/Server.hs b/Network/HQ/Server.hs --- a/Network/HQ/Server.hs +++ b/Network/HQ/Server.hs @@ -78,7 +78,12 @@ refH <- newIORef Nothing let readB = readSource' src req = Request $ InpObj vt Nothing readB refH - aux = Aux th mysa peersa + aux = + defaultAux + { auxTimeHandle = th + , auxMySockAddr = mysa + , auxPeerSockAddr = peersa + } server req aux $ sendResponse conf strm | otherwise = return () -- fixme: should consume the data? where diff --git a/Network/HTTP3/Client.hs b/Network/HTTP3/Client.hs --- a/Network/HTTP3/Client.hs +++ b/Network/HTTP3/Client.hs @@ -41,7 +41,7 @@ import Network.HTTP.Semantics.Client.Internal import Network.QUIC (Connection) import qualified Network.QUIC as QUIC -import Network.QUIC.Internal (possibleMyStreams) +import qualified Network.QUIC.Internal as QUIC import Text.Read (readMaybe) import Imports @@ -74,8 +74,9 @@ client (sendRequest ctx scheme authority) aux where aux = - Aux - { auxPossibleClientStreams = possibleMyStreams conn + defaultAux + { auxPossibleClientStreams = QUIC.possibleMyStreams conn + , auxSendPing = QUIC.sendFrames conn QUIC.RTT1Level [QUIC.Ping] } readerClient :: Context -> IO () diff --git a/Network/HTTP3/Context.hs b/Network/HTTP3/Context.hs --- a/Network/HTTP3/Context.hs +++ b/Network/HTTP3/Context.hs @@ -26,6 +26,7 @@ ) where import qualified Control.Exception as E +import Control.Monad (void) import qualified Data.ByteString as BS import Data.IORef import Network.HTTP.Semantics.Client @@ -122,8 +123,8 @@ let typ = toH3StreamType $ fromIntegral w8 ctxUniSwitch typ (recvStream strm) -withHandle :: Context -> (T.Handle -> IO a) -> IO (Maybe a) -withHandle Context{..} = T.withHandle ctxThreadManager (return ()) +withHandle :: Context -> (T.Handle -> IO ()) -> IO () +withHandle Context{..} action = void $ T.withHandle ctxThreadManager (return ()) action newStream :: Context -> IO Stream newStream Context{..} = stream ctxConnection diff --git a/Network/HTTP3/Server.hs b/Network/HTTP3/Server.hs --- a/Network/HTTP3/Server.hs +++ b/Network/HTTP3/Server.hs @@ -41,6 +41,7 @@ import Network.HTTP2.Server.Internal (ServerIO (..)) import Network.QUIC (Connection, ConnectionInfo (..), Stream, getConnectionInfo) import qualified Network.QUIC as QUIC +import Network.QUIC.Internal (mainDone) import qualified System.TimeManager as T import Imports @@ -74,6 +75,7 @@ , sioPeerSockAddr = remoteSockAddr info , sioReadRequest = atomically $ readTQueue reqq , sioWriteResponse = sendResponseIO ctx + , sioDone = mainDone conn } put strmreq = atomically $ writeTQueue reqq strmreq io <- action sio @@ -108,7 +110,12 @@ Nothing -> QUIC.resetStream strm H3MessageError Just ht -> do req <- mkRequest ctx strm src ht - let aux = Aux th (getMySockAddr ctx) (getPeerSockAddr ctx) + let aux = + defaultAux + { auxTimeHandle = th + , auxMySockAddr = getMySockAddr ctx + , auxPeerSockAddr = getPeerSockAddr ctx + } server req aux $ sendResponse ctx strm th where sid = QUIC.streamId strm 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.1.1 +version: 0.1.2 license: BSD-3-Clause license-file: LICENSE maintainer: Kazu Yamamoto @@ -81,18 +81,18 @@ bytestring, case-insensitive, containers, - http-semantics >= 0.3 && <0.4, + http-semantics >= 0.4 && <0.5, http-types, - http2 >=5.3.4 && <5.4, + http2 >=5.4 && <5.5, iproute >= 1.7 && < 1.8, network, network-byte-order, network-control >= 0.1.7 && <0.2, psqueues, - quic >= 0.2.11 && < 0.3, + quic >= 0.2.21 && < 0.3, sockaddr, stm, - time-manager >= 0.2.3 && <0.3, + time-manager >= 0.2.3 && <0.4, utf8-string >=1.0 && <1.1 executable h3-server diff --git a/util/ClientX.hs b/util/ClientX.hs --- a/util/ClientX.hs +++ b/util/ClientX.hs @@ -3,7 +3,7 @@ {-# LANGUAGE RecordWildCards #-} module ClientX ( - Aux (..), + Misc (..), Cli, clientHQ, clientH3, @@ -17,6 +17,7 @@ import qualified Data.ByteString.Char8 as C8 import Network.HTTP.Types import Network.QUIC +import System.IO import qualified Network.HQ.Client as HQ import Network.HTTP3.Client ( @@ -27,15 +28,17 @@ SendRequest, ) import qualified Network.HTTP3.Client as H3 +import qualified Network.QUIC.Internal as QUIC -data Aux = Aux - { auxAuthority :: String - , auxDebug :: String -> IO () - , auxShow :: ByteString -> IO () - , auxCheckClose :: IO Bool +data Misc = Misc + { miscAuthority :: String + , miscDebug :: String -> IO () + , miscShow :: ByteString -> IO () + , miscCheckClose :: IO Bool + , miscInteractive :: Bool } -type Cli = Aux -> [Path] -> Connection -> IO () +type Cli = Misc -> [Path] -> Connection -> IO () clientHQ :: Int -> Cli clientHQ n = clientX n HQ.run @@ -47,21 +50,27 @@ :: Int -> (Connection -> ClientConfig -> Config -> Client () -> IO ()) -> Cli -clientX n0 run aux@Aux{..} paths conn = E.bracket H3.allocSimpleConfig H3.freeSimpleConfig $ \conf -> - run conn cliconf conf $ client aux n0 paths +clientX n0 run misc@Misc{..} paths conn = E.bracket H3.allocSimpleConfig H3.freeSimpleConfig $ \conf -> + run conn cliconf conf $ client conn misc n0 paths where cliconf = H3.defaultClientConfig - { authority = auxAuthority + { authority = miscAuthority } -client :: Aux -> Int -> [Path] -> Client () -client aux n0 paths sendRequest _aux = - foldr1 concurrently_ $ - map (client' aux n0 sendRequest) paths +client :: Connection -> Misc -> Int -> [Path] -> Client () +client conn misc n0 paths sendRequest aux + | miscInteractive misc = do + console paths aux conn go + return () + | otherwise = go + where + go = + foldr1 concurrently_ $ + map (client' misc n0 sendRequest) paths -client' :: Aux -> Int -> SendRequest -> Path -> IO () -client' Aux{..} n0 sendRequest path = loop n0 +client' :: Misc -> Int -> SendRequest -> Path -> IO () +client' Misc{..} n0 sendRequest path = loop n0 where req = H3.requestNoBody @@ -71,10 +80,10 @@ loop 0 = return () loop n = do () <- sendRequest req $ \rsp -> do - auxDebug "GET" - auxShow "------------------------" + miscDebug "GET" + miscShow "------------------------" consume rsp - auxShow "------------------------" + miscShow "------------------------" when (n /= 1) $ do threadDelay 100000 loop (n - 1) @@ -82,8 +91,41 @@ bs <- H3.getResponseBodyChunk rsp if bs == "" then do - auxDebug "Fin received" + miscDebug "Fin received" else do - auxShow bs - auxDebug $ show (C8.length bs) ++ " bytes received" + miscShow bs + miscDebug $ show (C8.length bs) ++ " bytes received" consume rsp + +console :: [Path] -> H3.Aux -> Connection -> IO () -> IO () +console paths aux conn go = do + waitEstablished conn + putStrLn "q -- quit" + putStrLn "g -- get" + putStrLn "p -- ping" + putStrLn "n -- NAT rebinding" + mvar <- newEmptyMVar + loop mvar `E.catch` \(E.SomeException _) -> return () + where + loop mvar = 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 + _ <- go >> putMVar mvar () + takeMVar mvar + loop mvar + "p" -> do + putStrLn "Ping" + H3.auxSendPing aux + loop mvar + "n" -> do + QUIC.controlConnection conn QUIC.NATRebinding >>= print + loop mvar + _ -> do + putStrLn "No such command" + loop mvar diff --git a/util/h3-client.hs b/util/h3-client.hs --- a/util/h3-client.hs +++ b/util/h3-client.hs @@ -16,7 +16,6 @@ import System.Console.GetOpt import System.Environment import System.Exit -import System.IO import qualified System.Timeout as T import Text.Printf @@ -239,22 +238,23 @@ showContent | optShow = C8.putStrLn | otherwise = \_ -> return () - aux = - Aux - { auxAuthority = host - , auxDebug = debug - , auxShow = showContent - , auxCheckClose = do + misc = + Misc + { miscAuthority = host + , miscDebug = debug + , miscShow = showContent + , miscCheckClose = do mx <- T.timeout 1000000 $ takeMVar cmvar case mx of Nothing -> return False _ -> return True + , miscInteractive = optInteractive } - runClient cc opts aux paths + runClient cc opts misc paths -runClient :: ClientConfig -> Options -> Aux -> [H3.Path] -> IO () -runClient cc opts@Options{..} aux@Aux{..} paths = do - auxDebug "------------------------" +runClient :: ClientConfig -> Options -> Misc -> [H3.Path] -> IO () +runClient cc opts@Options{..} misc@Misc{..} paths = do + miscDebug "------------------------" (info1, info2, res, mig, client') <- run cc $ \conn -> do i1 <- getConnectionInfo conn let client = case alpn i1 of @@ -264,14 +264,10 @@ Nothing -> return False Just mtyp -> do x <- controlConnection conn mtyp - auxDebug $ "Migration by " ++ show mtyp + miscDebug $ "Migration by " ++ show mtyp return x t1 <- getUnixTime - if optInteractive - then do - console aux paths client conn - else do - client aux paths conn + client misc paths conn stats <- getConnectionStats conn print stats t2 <- getUnixTime @@ -289,7 +285,7 @@ | optResumption -> do if isResumptionPossible res then do - info3 <- runClient2 cc opts aux paths res client' + info3 <- runClient2 cc opts misc paths res client' if handshakeMode info3 == PreSharedKey then do putStrLn "Result: (R) TLS resumption ... OK" @@ -303,7 +299,7 @@ | opt0RTT -> do if is0RTTPossible res then do - info3 <- runClient2 cc opts aux paths res client' + info3 <- runClient2 cc opts misc paths res client' if handshakeMode info3 == RTT0 then do putStrLn "Result: (Z) 0-RTT ... OK" @@ -356,7 +352,7 @@ Nothing -> do putStrLn "Result: (H) handshake ... OK" putStrLn "Result: (D) stream data ... OK" - closeCompleted <- auxCheckClose + closeCompleted <- miscCheckClose when closeCompleted $ putStrLn "Result: (C) close completed ... OK" case alpn info1 of Nothing -> return () @@ -368,17 +364,17 @@ runClient2 :: ClientConfig -> Options - -> Aux + -> Misc -> [H3.Path] -> ResumptionInfo -> Cli -> IO ConnectionInfo -runClient2 cc Options{..} aux@Aux{..} paths res client = do +runClient2 cc Options{..} misc@Misc{..} paths res client = do threadDelay 100000 - auxDebug "<<<< next connection >>>>" - auxDebug "------------------------" + miscDebug "<<<< next connection >>>>" + miscDebug "------------------------" run cc' $ \conn -> do - void $ client aux paths conn + void $ client misc paths conn getConnectionInfo conn where cc' = @@ -406,34 +402,3 @@ / 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