warp 3.2.7 → 3.2.8
raw patch · 10 files changed
+232/−80 lines, 10 files
Files
- ChangeLog.md +6/−0
- Network/Wai/Handler/Warp.hs +3/−1
- Network/Wai/Handler/Warp/HTTP2/HPACK.hs +15/−7
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +2/−2
- Network/Wai/Handler/Warp/HTTP2/Request.hs +25/−8
- Network/Wai/Handler/Warp/HTTP2/Sender.hs +47/−30
- Network/Wai/Handler/Warp/HTTP2/Types.hs +18/−20
- Network/Wai/Handler/Warp/HTTP2/Worker.hs +14/−11
- test/inputFile +100/−0
- warp.cabal +2/−1
ChangeLog.md view
@@ -1,3 +1,9 @@+## 3.2.8++* Fixing HTTP2 requestBodyLength. [#573](https://github.com/yesodweb/wai/pull/573)+* Making HTTP/2 :path optional for the CONNECT method. [#572](https://github.com/yesodweb/wai/pull/572)+* Adding new APIs for HTTP/2 trailers: http2dataTrailers and modifyHTTP2Data [#566](https://github.com/yesodweb/wai/pull/566)+ ## 3.2.7 * Adding new APIs for HTTP/2 server push: getHTTP2Data and setHTTP2Data [#510](https://github.com/yesodweb/wai/pull/510)
Network/Wai/Handler/Warp.hs view
@@ -104,9 +104,11 @@ -- ** HTTP2 data , HTTP2Data , http2dataPushPromise+ , http2dataTrailers , defaultHTTP2Data , getHTTP2Data , setHTTP2Data+ , modifyHTTP2Data -- ** Push promise , PushPromise , promisedPath@@ -129,7 +131,7 @@ import Network.Wai.Handler.Warp.Response (warpVersion) import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings-import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data)+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data) import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types hiding (getFileInfo)
Network/Wai/Handler/Warp/HTTP2/HPACK.hs view
@@ -83,13 +83,21 @@ {-# INLINE checkRequestHeader #-} checkRequestHeader :: ValueTable -> Bool checkRequestHeader reqvt- | getHeaderValue tokenStatus reqvt /= Nothing = False- | getHeaderValue tokenPath reqvt == Nothing = False- | getHeaderValue tokenMethod reqvt == Nothing = False- | getHeaderValue tokenAuthority reqvt == Nothing = False- | getHeaderValue tokenConnection reqvt /= Nothing = False- | just (getHeaderValue tokenTE reqvt) (/= "trailers") = False- | otherwise = True+ | mStatus /= Nothing = False+ | mMethod == Nothing = False+ | mAuthority == Nothing = False+ | mConnection /= Nothing = False+ | just mTE (/= "trailers") = False+ | just mMethod (== "CONNECT") = mPath == Nothing && mScheme == Nothing+ | otherwise = mPath /= Nothing+ where+ mStatus = getHeaderValue tokenStatus reqvt+ mScheme = getHeaderValue tokenScheme reqvt+ mPath = getHeaderValue tokenPath reqvt+ mMethod = getHeaderValue tokenMethod reqvt+ mAuthority = getHeaderValue tokenAuthority reqvt+ mConnection = getHeaderValue tokenConnection reqvt+ mTE = getHeaderValue tokenTE reqvt {-# INLINE just #-} just :: Maybe a -> (a -> Bool) -> Bool
Network/Wai/Handler/Warp/HTTP2/Receiver.hs view
@@ -122,7 +122,7 @@ E.throwIO $ StreamError ProtocolError streamId writeIORef streamPrecedence $ toPrecedence pri writeIORef streamState HalfClosed- (!req, !ii) <- mkreq tbl (return "")+ (!req, !ii) <- mkreq tbl (Just 0, return "") atomically $ writeTQueue inputQ $ Input strm req reqvt ii Open (HasBody tbl@(_,reqvt) pri) -> do resetContinued@@ -133,7 +133,7 @@ writeIORef streamState $ Open (Body q mcl bodyLength) readQ <- newReadBody q bodySource <- mkSource readQ- (!req, !ii) <- mkreq tbl (readSource bodySource)+ (!req, !ii) <- mkreq tbl (mcl, readSource bodySource) atomically $ writeTQueue inputQ $ Input strm req reqvt ii s@(Open Continued{}) -> do setContinued
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -6,6 +6,7 @@ , MkReq , getHTTP2Data , setHTTP2Data+ , modifyHTTP2Data ) where import Control.Applicative ((<|>))@@ -29,17 +30,17 @@ import Network.Wai.Internal (Request(..)) import System.IO.Unsafe (unsafePerformIO) -type MkReq = (TokenHeaderList,ValueTable) -> IO ByteString -> IO (Request,InternalInfo)+type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo) mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq-mkRequest ii1 settings addr (reqths,reqvt) body = do+mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do ref <- newIORef Nothing- mkRequest' ii1 settings addr ref (reqths,reqvt) body+ mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr -> IORef (Maybe HTTP2Data) -> MkReq-mkRequest' ii1 settings addr ref (reqths,reqvt) body = return (req,ii)+mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii) where !req = Request { requestMethod = colonMethod@@ -53,7 +54,7 @@ , remoteHost = addr , requestBody = body , vault = vaultValue- , requestBodyLength = ChunkedBody -- fixme+ , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen , requestHeaderHost = mHost <|> mAuth , requestHeaderRange = mRange , requestHeaderReferer = mReferer@@ -66,14 +67,16 @@ Nothing -> case mAuth of Just auth -> (tokenHost, auth) : reqths _ -> reqths- !colonPath = fromJust $ getHeaderValue tokenPath reqvt -- MUST+ !mPath = getHeaderValue tokenPath reqvt -- SHOULD !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD !mHost = getHeaderValue tokenHost reqvt !mRange = getHeaderValue tokenRange reqvt !mReferer = getHeaderValue tokenReferer reqvt !mUserAgent = getHeaderValue tokenUserAgent reqvt- (unparsedPath,query) = B8.break (=='?') colonPath+ -- CONNECT request will have ":path" omitted, use ":authority" as unparsed+ -- path instead so that it will have consistent behavior compare to HTTP 1.0+ (unparsedPath,query) = B8.break (=='?') $ fromJust (mPath <|> mAuth) !path = H.extractPath unparsedPath !rawPath = if S.settingsNoParsePath settings then unparsedPath else path !h = hashByteString rawPath@@ -83,6 +86,7 @@ $ Vault.insert getFileInfoKey (getFileInfo ii) $ Vault.insert getHTTP2DataKey (readIORef ref) $ Vault.insert setHTTP2DataKey (writeIORef ref)+ $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref) Vault.empty getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))@@ -103,10 +107,23 @@ {-# NOINLINE setHTTP2Data #-} -- | Setting 'HTTP2Data' through vault of the request.--- 'Middleware' should use this.+-- 'Application' or 'Middleware' should use this. -- -- Since: 3.2.7 setHTTP2Data :: Request -> Maybe HTTP2Data -> IO () setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of Nothing -> return () Just setter -> setter mh2d++modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())+modifyHTTP2DataKey = unsafePerformIO Vault.newKey+{-# NOINLINE modifyHTTP2Data #-}++-- | Modifying 'HTTP2Data' through vault of the request.+-- 'Application' or 'Middleware' should use this.+--+-- Since: 3.2.8+modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()+modifyHTTP2Data req func = case Vault.lookup modifyHTTP2DataKey (vault req) of+ Nothing -> return ()+ Just modify -> modify func
Network/Wai/Handler/Warp/HTTP2/Sender.hs view
@@ -18,7 +18,7 @@ import Data.Word (Word8, Word32) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (poke)-import Network.HPACK (setLimitForEncoding)+import Network.HPACK (setLimitForEncoding, toHeaderTable) import Network.HTTP2 import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence) import Network.Wai@@ -122,16 +122,16 @@ Nothing -> return () Just siz -> setLimitForEncoding siz encodeDynamicTable - output (ONext strm curr mtbq tell) off0 lim = do+ output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do -- Data frame payload let !buf = connWriteBuffer `plusPtr` off0 !siz = connBufferSize - off0 Next datPayloadLen mnext <- curr buf siz lim- off <- fillDataHeader strm off0 datPayloadLen mnext tell- maybeEnqueueNext strm mtbq mnext tell+ off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D+ maybeEnqueueNext out mnext return off - output (ORspn strm rspn ii tell) off0 lim = do+ output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do -- Header frame and Continuation frame let !sid = streamNumber strm !endOfStream = case rspn of@@ -149,32 +149,32 @@ let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillFileBodyGetNext conn ii payloadOff lim path mpart- off' <- fillDataHeader strm off datPayloadLen mnext tell- maybeEnqueueNext strm Nothing mnext tell+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D+ maybeEnqueueNext out mnext return off' RspnBuilder _ _ builder -> do -- Data frame payload let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillBuilderBodyGetNext conn ii payloadOff lim builder- off' <- fillDataHeader strm off datPayloadLen mnext tell- maybeEnqueueNext strm Nothing mnext tell+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D+ maybeEnqueueNext out mnext return off' RspnStreaming _ _ tbq -> do let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillStreamBodyGetNext conn payloadOff lim tbq strm- off' <- fillDataHeader strm off datPayloadLen mnext tell- maybeEnqueueNext strm (Just tbq) mnext tell+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D+ maybeEnqueueNext out mnext return off' - output (OPush strm ths rspn ii tell pid) off0 lim = do+ output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do -- Creating a push promise header -- Frame id should be associated stream id from the client. let !sid = streamNumber strm len <- pushPromise pid sid ths off0 off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len- output (ORspn strm rspn ii tell) off lim+ output out{ outputType = ORspn } off lim output _ _ _ = undefined -- never reach @@ -183,9 +183,12 @@ if isClosed state then return off else case out of- OWait strm' rsp ii wait -> do+ Output _ _ _ wait _ OWait -> do -- Checking if all push are done.- let out' = ORspn strm' rsp ii (return ())+ let out' = out {+ outputHook = return ()+ , outputType = ORspn+ } forkAndEnqueueWhenReady wait outputQ out' mgr return off _ -> case mtbq of@@ -252,12 +255,11 @@ {-# INLINE maybeEnqueueNext #-} -- Re-enqueue the stream in the output queue.- maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence)- -> Maybe DynaNext -> IO () -> IO ()- maybeEnqueueNext _ _ Nothing _ = return ()- maybeEnqueueNext strm mtbq (Just next) tell = enqueueOutput outputQ out+ maybeEnqueueNext :: Output -> Maybe DynaNext -> IO ()+ maybeEnqueueNext _ Nothing = return ()+ maybeEnqueueNext out (Just next) = enqueueOutput outputQ out' where- !out = ONext strm next mtbq tell+ !out' = out { outputType = ONext next } {-# INLINE sendHeadersIfNecessary #-} -- Send headers if there is not room for a 1-byte data frame, and return@@ -269,21 +271,36 @@ flushN off return 0 - fillDataHeader strm off datPayloadLen mnext tell = do+ fillDataHeader strm@Stream{streamWindow,streamNumber}+ off datPayloadLen mnext tell getH2D = do -- Data frame header- let !sid = streamNumber strm+ mh2d <- getH2D+ let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of+ Nothing -> ([], True)+ Just ts -> (ts, null ts) !buf = connWriteBuffer `plusPtr` off !off' = off + frameHeaderLength + datPayloadLen- !done = isNothing mnext- flag | done = setEndStream defaultFlags- | otherwise = defaultFlags- fillFrameHeader FrameData datPayloadLen sid flag buf- when done $ do+ !noMoreBody = isNothing mnext+ flag | noMoreBody && noTrailers = setEndStream defaultFlags+ | otherwise = defaultFlags+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf+ off'' <- handleEndOfBody noMoreBody off' noTrailers trailers+ atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)+ atomically $ modifyTVar' streamWindow (subtract datPayloadLen)+ return off''+ where+ handleTrailers True off0 _ = return off0+ handleTrailers _ off0 trailers = do+ (ths,_) <- toHeaderTable trailers+ kvlen <- headerContinue streamNumber ths True off0+ sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen+ handleEndOfBody True off0 noTrailers trailers = do+ off1 <- handleTrailers noTrailers off0 trailers void $ tell closed ctx strm Finished- atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)- atomically $ modifyTVar' (streamWindow strm) (subtract datPayloadLen)- return off'+ return off1+ handleEndOfBody False off0 _ _ = return off0+ pushPromise pid sid ths off = do let !offsid = off + frameHeaderLength
Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -68,27 +68,23 @@ rspnHeaders (RspnBuilder _ t _) = t rspnHeaders (RspnFile _ t _ _ ) = t -data Output = ORspn !Stream !Rspn !InternalInfo (IO ()) -- done- | OWait !Stream !Rspn !InternalInfo (IO ()) -- done- | OPush !Stream -- stream for this push from this server- TokenHeaderList- !Rspn {- RspnFile only-}- !InternalInfo (IO ()) -- wait for done- !StreamId -- associated stream id from client- | ONext !Stream !DynaNext !(Maybe (TBQueue Sequence)) (IO ()) -- done+data Output = Output {+ outputStream :: !Stream+ , outputRspn :: !Rspn+ , outputII :: !InternalInfo+ , outputHook :: IO () -- OPush: wait for done, O*: telling done+ , outputH2Data :: IO (Maybe HTTP2Data)+ , outputType :: !OutputType+ } -outputStream :: Output -> Stream-outputStream (ORspn strm _ _ _) = strm-outputStream (OPush strm _ _ _ _ _) = strm-outputStream (OWait strm _ _ _) = strm-outputStream (ONext strm _ _ _) = strm+data OutputType = ORspn+ | OWait+ | OPush !TokenHeaderList !StreamId -- associated stream id from client+ | ONext !DynaNext outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)-outputMaybeTBQueue (ORspn _ (RspnStreaming _ _ tbq) _ _) = Just tbq-outputMaybeTBQueue (ORspn _ _ _ _) = Nothing-outputMaybeTBQueue (OPush _ _ _ _ _ _) = Nothing-outputMaybeTBQueue (OWait _ _ _ _) = Nothing-outputMaybeTBQueue (ONext _ _ mtbq _) = mtbq+outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq+outputMaybeTBQueue _ = Nothing data Control = CFinish | CGoaway !ByteString@@ -286,18 +282,20 @@ -- | HTTP/2 specific data. -- -- Since: 3.2.7-newtype HTTP2Data = HTTP2Data {+data HTTP2Data = HTTP2Data { -- | Accessor for 'PushPromise' in 'HTTP2Data'. -- -- Since: 3.2.7 http2dataPushPromise :: [PushPromise]+ -- Since: 3.2.8+ , http2dataTrailers :: H.ResponseHeaders } deriving (Eq,Show) -- | Default HTTP/2 specific data. -- -- Since: 3.2.7 defaultHTTP2Data :: HTTP2Data-defaultHTTP2Data = HTTP2Data []+defaultHTTP2Data = HTTP2Data [] [] -- | HTTP/2 push promise or sever push. --
Network/Wai/Handler/Warp/HTTP2/Worker.hs view
@@ -57,7 +57,7 @@ pushStream :: Context -> S.Settings -> StreamId -> ValueTable -> Request -> InternalInfo -> Maybe HTTP2Data- -> IO (Stream -> Rspn -> InternalInfo -> IO () -> Output, IO ())+ -> IO (OutputType, IO ()) pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ()) pushStream ctx@Context{http2settings,outputQ,streamTable} settings pid reqvt req ii (Just h2d)@@ -81,6 +81,7 @@ waiter lim tvar = atomically $ do n <- readTVar tvar check (n >= lim)+ !h2data = getHTTP2Data req push _ [] !n = return (n :: Int) push tvar (pp:pps) !n = do let !file = promisedFile pp@@ -110,7 +111,8 @@ !ths = (tokenLastModified,date) : addContentHeadersForFilePart ths0 part pushLogger req path size- let out = OPush strm promisedRequest rsp ii (increment tvar) pid+ let !ot = OPush promisedRequest pid+ !out = Output strm rsp ii (increment tvar) h2data ot enqueueOutput outputQ out push tvar pps (n + 1) @@ -144,6 +146,7 @@ !logger = S.settingsLogger settings !th = threadHandle ii sid = streamNumber strm+ !h2data = getHTTP2Data req -- Ideally, log messages should be written when responses are -- actually sent. But there is no way to keep good memory usage@@ -156,8 +159,8 @@ responseNoBody' s tbl = do logger req s Nothing setThreadContinue tconf True- let rspn = RspnNobody s tbl- out = ORspn strm rspn ii (return ())+ let !rspn = RspnNobody s tbl+ !out = Output strm rspn ii (return ()) h2data ORspn enqueueOutput outputQ out return ResponseReceived @@ -165,8 +168,8 @@ logger req s Nothing setThreadContinue tconf True tbl <- toHeaderTable hs0- let rspn = RspnBuilder s tbl bdy- out = rspnOrWait strm rspn ii tell+ let !rspn = RspnBuilder s tbl bdy+ !out = Output strm rspn ii tell h2data rspnOrWait enqueueOutput outputQ out return ResponseReceived @@ -191,8 +194,8 @@ | otherwise = do logger req s (filePartByteCount <$> mpart) setThreadContinue tconf True- let rspn = RspnFile s tbl path mpart- out = rspnOrWait strm rspn ii tell+ let !rspn = RspnFile s tbl path mpart+ !out = Output strm rspn ii tell h2data rspnOrWait enqueueOutput outputQ out return ResponseReceived @@ -217,8 +220,8 @@ -- So, let's serialize 'Builder' with a designated queue. tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 tbl <- toHeaderTable hs0- let rspn = RspnStreaming s0 tbl tbq- out = rspnOrWait strm rspn ii tell+ let !rspn = RspnStreaming s0 tbl tbq+ !out = Output strm rspn ii tell h2data rspnOrWait enqueueOutput outputQ out let push b = do atomically $ writeTBQueue tbq (SBuilder b)@@ -265,7 +268,7 @@ Nothing -> return () Just (Input strm req _reqvt _ii) -> do closed ctx strm Killed- let frame = resetFrame InternalError (streamNumber strm)+ let !frame = resetFrame InternalError (streamNumber strm) enqueueControl controlQ $ CFrame frame case me of Nothing -> return ()
+ test/inputFile view
@@ -0,0 +1,100 @@+A acid+abacus major+abacus pythagoricus+A battery+abbey counter+abbey laird+abbey lands+abbey lubber+abbot cloth+Abbott papyrus+abb wool+A-b-c book+A-b-c method+abdomino-uterotomy+Abdul-baha+a-be+aberrant duct+aberration constant+abiding place+able-bodied+able-bodiedness+able-minded+able-mindedness+able seaman+aboli fruit+A bond+Abor-miri+a-borning+about-face+about ship+about-sledge+above-cited+above-found+above-given+above-mentioned+above-named+above-quoted+above-reported+above-said+above-water+above-written+Abraham-man+abraum salts+abraxas stone+Abri audit culture+abruptly acuminate+abruptly pinnate+absciss layer+absence state+absentee voting+absent-minded+absent-mindedly+absent-mindedness+absent treatment+absent voter+Absent voting+absinthe green+absinthe oil+absorption bands+absorption circuit+absorption coefficient+absorption current+absorption dynamometer+absorption factor+absorption lines+absorption pipette+absorption screen+absorption spectrum+absorption system+A b station+abstinence theory+abstract group+Abt system+abundance declaree+aburachan seed+abutment arch+abutment pier+abutting joint+acacia veld+academy blue+academy board+academy figure+acajou balsam+acanthosis nigricans+acanthus family+acanthus leaf+acaroid resin+Acca larentia+acceleration note+accelerator nerve+accent mark+acceptance bill+acceptance house+acceptance supra protest+acceptor supra protest+accession book+accession number+accession service+access road+accident insurance
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.2.7+Version: 3.2.8 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -19,6 +19,7 @@ ChangeLog.md README.md test/head-response+ test/inputFile Flag network-bytestring Default: False