diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for http3 +## 0.0.5 + +* Supporting http2 v4.2.0. + ## 0.0.4 * Using "crypton" intead of "cryptonite". diff --git a/Network/HQ/Client.hs b/Network/HQ/Client.hs --- a/Network/HQ/Client.hs +++ b/Network/HQ/Client.hs @@ -28,6 +28,7 @@ import qualified Data.ByteString as BS import Data.IORef +import Data.Maybe (fromJust) import Network.HPACK import qualified Network.HTTP2.Client as H2 import Network.HTTP2.Client.Internal (Request(..), Response(..)) @@ -47,7 +48,7 @@ sendRequest :: Connection -> Request -> (Response -> IO a) -> IO a sendRequest conn (Request outobj) processResponse = E.bracket open close $ \strm -> do let hdr = H2.outObjHeaders outobj - Just path = lookup ":path" hdr + path = fromJust $ lookup ":path" hdr requestLine = BS.concat ["GET ", path, "\r\n"] QUIC.sendStream strm requestLine QUIC.shutdownStream strm diff --git a/Network/HQ/Server.hs b/Network/HQ/Server.hs --- a/Network/HQ/Server.hs +++ b/Network/HQ/Server.hs @@ -51,21 +51,23 @@ -- | Running an HQ server. run :: Connection -> Config -> Server -> IO () run conn conf server = do - myaddr <- QUIC.localSockAddr <$> QUIC.getConnectionInfo conn + info <- QUIC.getConnectionInfo conn + let mysa = QUIC.localSockAddr info + peersa = QUIC.remoteSockAddr info forever $ do strm <- QUIC.acceptStream conn - forkFinally (processRequest conf myaddr server strm) (\_ -> QUIC.closeStream strm) + forkFinally (processRequest conf mysa peersa server strm) (\_ -> QUIC.closeStream strm) -processRequest :: Config -> SockAddr -> Server -> Stream -> IO () -processRequest conf myaddr server strm +processRequest :: Config -> SockAddr -> SockAddr -> Server -> Stream -> IO () +processRequest conf mysa peersa server strm | QUIC.isClientInitiatedBidirectional sid = do th <- T.register (confTimeoutManager conf) (return ()) - vt <- recvHeader strm myaddr + vt <- recvHeader strm mysa src <- newSource strm refH <- newIORef Nothing let readB = readSource src req = Request $ InpObj vt Nothing readB refH - aux = Aux th + aux = Aux th mysa peersa server req aux $ sendResponse conf strm | otherwise = return () -- fixme: should consume the data? where @@ -111,6 +113,8 @@ let next = H2.fillBuilderBodyGetNext builder sendNext strm next H2.OutBodyStreaming strmbdy -> sendStreaming strm strmbdy + H2.OutBodyStreamingUnmask _ -> + error "sendResponse: server does not support OutBodyStreamingUnmask" sendNext :: Stream -> H2.DynaNext -> IO () sendNext strm action = do diff --git a/Network/HTTP3/Context.hs b/Network/HTTP3/Context.hs --- a/Network/HTTP3/Context.hs +++ b/Network/HTTP3/Context.hs @@ -20,6 +20,8 @@ , abort , getHooks , Hooks(..) -- re-export + , getMySockAddr + , getPeerSockAddr ) where import Control.Concurrent @@ -28,6 +30,7 @@ import Network.HTTP2.Internal (PositionReadMaker) import Network.QUIC import Network.QUIC.Internal (isServer, isClient, connDebugLog) +import Network.Socket (SockAddr) import System.Mem.Weak import qualified System.TimeManager as T import qualified UnliftIO.Exception as E @@ -45,6 +48,8 @@ , ctxPReadMaker :: PositionReadMaker , ctxManager :: T.Manager , ctxHooks :: Hooks + , ctxMySockAddr :: SockAddr + , ctxPeerSockAddr :: SockAddr , ctxThreads :: IORef [Weak ThreadId] } @@ -52,13 +57,16 @@ newContext conn conf ctl = do (enc, handleDI) <- newQEncoder defaultQEncoderConfig (dec, handleEI) <- newQDecoder defaultQDecoderConfig + info <- getConnectionInfo conn let handleDI' recv = handleDI recv `E.catchAny` abortWith QpackDecoderStreamError handleEI' recv = handleEI recv `E.catchAny` abortWith QpackEncoderStreamError sw = switch conn ctl handleEI' handleDI' preadM = confPositionReadMaker conf timmgr = confTimeoutManager conf hooks = confHooks conf - Context conn enc dec sw preadM timmgr hooks <$> newIORef [] + mysa = localSockAddr info + peersa = remoteSockAddr info + Context conn enc dec sw preadM timmgr hooks mysa peersa <$> newIORef [] where abortWith aerr _se = abortConnection conn aerr "" @@ -129,3 +137,9 @@ getHooks :: Context -> Hooks getHooks = ctxHooks + +getMySockAddr :: Context -> SockAddr +getMySockAddr = ctxMySockAddr + +getPeerSockAddr :: Context -> SockAddr +getPeerSockAddr = ctxMySockAddr diff --git a/Network/HTTP3/Send.hs b/Network/HTTP3/Send.hs --- a/Network/HTTP3/Send.hs +++ b/Network/HTTP3/Send.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Network.HTTP3.Send ( sendHeader @@ -12,9 +13,10 @@ import Foreign.ForeignPtr import Network.HPACK (toHeaderTable) import qualified Network.HTTP.Types as HT -import Network.HTTP2.Internal +import Network.HTTP2.Internal hiding (timeoutClose) import Network.QUIC import qualified System.TimeManager as T +import qualified UnliftIO.Exception as E import Imports import Network.HTTP3.Context @@ -44,7 +46,8 @@ OutBodyBuilder builder -> do let next = fillBuilderBodyGetNext builder sendNext ctx strm th next tlrmkr - OutBodyStreaming strmbdy -> sendStreaming ctx strm th strmbdy tlrmkr + OutBodyStreaming strmbdy -> sendStreaming ctx strm th tlrmkr (\unmask push flush -> unmask $ strmbdy push flush) + OutBodyStreamingUnmask strmbdy -> sendStreaming ctx strm th tlrmkr strmbdy where tlrmkr = outObjTrailers outobj @@ -84,10 +87,12 @@ T.tickle th return (signal, tlrmkr1) -sendStreaming :: Context -> Stream -> T.Handle -> ((Builder -> IO ()) -> IO () -> IO ()) -> TrailersMaker -> IO () -sendStreaming ctx strm th strmbdy tlrmkr0 = do +sendStreaming :: Context -> Stream -> T.Handle -> TrailersMaker + -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ()) + -> IO () +sendStreaming ctx strm th tlrmkr0 strmbdy = do ref <- newIORef tlrmkr0 - strmbdy (write ref) flush + E.mask $ \unmask -> strmbdy unmask (write ref) flush tlrmkr <- readIORef ref Trailers trailers <- tlrmkr Nothing unless (null trailers) $ sendHeader ctx strm th trailers diff --git a/Network/HTTP3/Server.hs b/Network/HTTP3/Server.hs --- a/Network/HTTP3/Server.hs +++ b/Network/HTTP3/Server.hs @@ -130,13 +130,13 @@ case (mMethod, mScheme, mAuthority, mPath) of (Just "CONNECT", _, Just _, _) -> return () (Just _, Just _, Just _, Just _) -> return () - otherwise -> QUIC.resetStream strm H3MessageError + _ -> QUIC.resetStream strm H3MessageError -- fixme: Content-Length refI <- newIORef IInit refH <- newIORef Nothing let readB = recvBody ctx src refI refH req = Request $ InpObj ht Nothing readB refH - let aux = Aux th + let aux = Aux th (getMySockAddr ctx) (getPeerSockAddr ctx) server req aux $ sendResponse ctx strm th where reset se diff --git a/Network/QPACK/Table/Dynamic.hs b/Network/QPACK/Table/Dynamic.hs --- a/Network/QPACK/Table/Dynamic.hs +++ b/Network/QPACK/Table/Dynamic.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE RecordWildCards #-} module Network.QPACK.Table.Dynamic where 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.4 +version: 0.0.5 license: BSD-3-Clause license-file: LICENSE maintainer: Kazu Yamamoto @@ -81,7 +81,7 @@ bytestring, case-insensitive, containers, - http2 >=4.1.3 && <5, + http2 >=4.2.0 && <5, http-types, network, network-byte-order, diff --git a/util/ClientX.hs b/util/ClientX.hs --- a/util/ClientX.hs +++ b/util/ClientX.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE RankNTypes #-} module ClientX where diff --git a/util/client.hs b/util/client.hs --- a/util/client.hs +++ b/util/client.hs @@ -154,14 +154,12 @@ main = do args <- getArgs (opts@Options{..}, ips) <- clientOpts args - let ipslen = length ips - when (ipslen /= 2 && ipslen /= 3) $ - showUsageAndExit "cannot recognize and \n" + (addr,port,path) <- case ips of + [a,b] -> return (a,b,"/") + [a,b,c] -> return (a,b,c) + _ -> showUsageAndExit "cannot recognize and \n" cmvar <- newEmptyMVar - let path | ipslen == 3 = ips !! 2 - | otherwise = "/" - addr:port:_ = ips - ccalpn ver + let ccalpn ver | optPerformance /= 0 = return $ Just ["perf"] | otherwise = let (h3X, hqX) = makeProtos ver protos | optHQ = [hqX,h3X]