diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,25 @@ # ChangeLog for warp +## 3.4.19 + +* Security: `Host` is validated. A HTTP/1.1 request without one, and any + request with more than one, is refused: a router reading the first and an + application reading `requestHeaderHost` could disagree about which host a + request was for. +* Security: a `Range` which does not begin inside the file is answered 416, + rather than dropping the connection with no answer at all. +* Security: `packIntegral` counts its digits by division. The `Double` + logarithm it used was one short from 10^15 up, and the last digit was + written before the buffer. +* Security: the HTTP/2 connection a GOAWAY for weak TLS ends is no longer + served afterwards, and that GOAWAY now follows the SETTINGS frame which + RFC 9113 has a server send first. +* Security: the HTTP/2 `response` continuation is not called a second time + when an application throws after its response has gone out. +* `InvalidRequest` gains `BadHost`. +* Header field names are validated by a lookup table rather than by a chain + of range tests. + ## 3.4.18 * The accept loop is stopped by being told, through the new diff --git a/Network/Wai/Handler/Warp/File.hs b/Network/Wai/Handler/Warp/File.hs --- a/Network/Wai/Handler/Warp/File.hs +++ b/Network/Wai/Handler/Warp/File.hs @@ -139,21 +139,28 @@ parseRange :: ByteString -> Integer -> RspFileInfo parseRange rng size = case H.parseByteRanges rng of - Nothing -> WithoutBody H.requestedRangeNotSatisfiable416 - Just [] -> WithoutBody H.requestedRangeNotSatisfiable416 - Just (r : _) -> - let (!beg, !end) = checkRange r size - !len = end - beg + 1 + Just (r : _) | Just (!beg, !end) <- checkRange r size -> + let !len = end - beg + 1 s = if beg == 0 && end == size - 1 then H.ok200 else H.partialContent206 in WithBody s [] beg len + _ -> WithoutBody H.requestedRangeNotSatisfiable416 -checkRange :: H.ByteRange -> Integer -> (Integer, Integer) -checkRange (H.ByteRangeFrom beg) size = (beg, size - 1) -checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end) -checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1) +-- | The first and last byte a range asks for, or 'Nothing' when it asks +-- for nothing the file holds, which RFC 9110 section 14.4 answers with +-- 416. +checkRange :: H.ByteRange -> Integer -> Maybe (Integer, Integer) +checkRange (H.ByteRangeFrom beg) size + | beg < 0 || beg >= size = Nothing + | otherwise = Just (beg, size - 1) +checkRange (H.ByteRangeFromTo beg end) size + | beg < 0 || beg > end || beg >= size = Nothing + | otherwise = Just (beg, min (size - 1) end) +checkRange (H.ByteRangeSuffix count) size + | count <= 0 || size <= 0 = Nothing + | otherwise = Just (max 0 (size - count), size - 1) ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/HTTP2.hs b/Network/Wai/Handler/Warp/HTTP2.hs --- a/Network/Wai/Handler/Warp/HTTP2.hs +++ b/Network/Wai/Handler/Warp/HTTP2.hs @@ -74,14 +74,21 @@ , H2.confPeerSockAddr = peersa , H2.confReadNTimeout = True } - checkTLS + ok <- checkTLS setConnHTTP2 conn True - H2.run H2.defaultServerConfig conf $ - http2server "Warp HTTP/2" settings ii transport peersa app + when ok $ + H2.run H2.defaultServerConfig conf $ + http2server "Warp HTTP/2" settings ii transport peersa app where + -- A GOAWAY ends the connection, so there is nothing left to serve + -- on it. checkTLS = case transport of - TCP -> return () -- direct - tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS" + TCP -> return True -- direct + tls + | tls12orLater tls -> return True + | otherwise -> do + goaway conn H2.InadequateSecurity "Weak TLS" + return False tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3 -- | Converting WAI application to the server type of http2 library. @@ -111,22 +118,31 @@ I.writeIORef ref $ Just (h2rsp, pps, st) _ <- response h2rsp pps return ResponseReceived - case eResponseReceived of - Right ResponseReceived -> do - Just (h2rsp, pps, st) <- I.readIORef ref + msent <- I.readIORef ref + let logSent (h2rsp, pps, st) = do let msiz = fromIntegral <$> H2.responseBodySize h2rsp logResponse req st msiz mapM_ (logPushPromise req) pps + case eResponseReceived of + Right ResponseReceived -> case msent of + Just sent -> logSent sent + -- Reachable only through Network.Wai.Internal: the + -- application said it had answered without answering. + Nothing -> E.throwIO $ userError "no response from the application" Left e | isAsyncException e -> E.throwIO e | otherwise -> do S.settingsOnException settings (Just req) e - let ersp = S.settingsOnExceptionResponse settings e - st = responseStatus ersp - (h2rsp', _, _) <- fromResponse settings ii req ersp - let msiz = fromIntegral <$> H2.responseBodySize h2rsp' - _ <- response h2rsp' [] - logResponse req st msiz + case msent of + -- The response has gone out, so this exception + -- cannot replace it, which is what istatus keeps + -- HTTP/1 from doing. + Just sent -> logSent sent + Nothing -> do + let ersp = S.settingsOnExceptionResponse settings e + (h2rsp, _, _) <- fromResponse settings ii req ersp + _ <- response h2rsp [] + logSent (h2rsp, [], responseStatus ersp) return () where toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport @@ -164,9 +180,13 @@ handler = throughAsync (return "") -- connClose must not be called here since Run:fork calls it +-- +-- The SETTINGS frame is this server's half of the connection preface, +-- which RFC 9113 has it send before anything else, GOAWAY included. goaway :: Connection -> H2.ErrorCode -> ByteString -> IO () -goaway Connection{..} etype debugmsg = connSendAll bytestream +goaway Connection{..} etype debugmsg = connSendAll $ preface <> bytestream where einfo = H2.encodeInfo id 0 + preface = H2.encodeFrame einfo $ H2.SettingsFrame [] frame = H2.GoAwayFrame 0 etype debugmsg bytestream = H2.encodeFrame einfo frame diff --git a/Network/Wai/Handler/Warp/Header.hs b/Network/Wai/Handler/Warp/Header.hs --- a/Network/Wai/Handler/Warp/Header.hs +++ b/Network/Wai/Handler/Warp/Header.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString as BS import Data.CaseInsensitive (foldedCase) import Data.List as L (foldl') +import Data.Maybe (isJust) import Network.HTTP.Types import Network.Wai.Handler.Warp.Types @@ -27,6 +28,8 @@ , reqidxConnection :: Maybe HeaderValue , reqidxRange :: Maybe HeaderValue , reqidxHost :: Maybe HeaderValue + , reqidxHostRepeated :: Bool + -- ^ Whether more than one @Host@ field line was sent. , reqidxIfModifiedSince :: Maybe HeaderValue , reqidxIfUnmodifiedSince :: Maybe HeaderValue , reqidxIfRange :: Maybe HeaderValue @@ -40,7 +43,12 @@ indexRequestHeader = L.foldl' insert defaultIndexRequestHeader where insert ix (key, val) = case BS.length bs of - 4 | bs == "host" -> ix{reqidxHost = Just val} + 4 + | bs == "host" -> + ix + { reqidxHost = Just val + , reqidxHostRepeated = isJust (reqidxHost ix) + } 5 | bs == "range" -> ix{reqidxRange = Just val} 6 | bs == "expect" -> ix{reqidxExpect = Just val} 7 | bs == "referer" -> ix{reqidxReferer = Just val} @@ -79,6 +87,7 @@ , reqidxConnection = Nothing , reqidxRange = Nothing , reqidxHost = Nothing + , reqidxHostRepeated = False , reqidxIfModifiedSince = Nothing , reqidxIfUnmodifiedSince = Nothing , reqidxIfRange = Nothing diff --git a/Network/Wai/Handler/Warp/PackInt.hs b/Network/Wai/Handler/Warp/PackInt.hs --- a/Network/Wai/Handler/Warp/PackInt.hs +++ b/Network/Wai/Handler/Warp/PackInt.hs @@ -16,8 +16,10 @@ packIntegral n | n < 0 = error "packIntegral" packIntegral n = unsafeCreate len go0 where - n' = fromIntegral n + 1 :: Double - len = ceiling $ logBase 10 n' + -- Counted by division: @ceiling (logBase 10 ...)@ in a 'Double' is + -- one short from 10^15 up, and 'go' then writes its last digit + -- before the buffer it was given. + !len = numDigits n go0 p = go n $ p `plusPtr` (len - 1) go :: Integral a => a -> Ptr Word8 -> IO () go i p = do @@ -26,6 +28,16 @@ when (d /= 0) $ go d (p `plusPtr` (-1)) {-# SPECIALIZE packIntegral :: Int -> ByteString #-} {-# SPECIALIZE packIntegral :: Integer -> ByteString #-} + +-- | How many digits a non-negative number is written with. +numDigits :: Integral a => a -> Int +numDigits = go 1 + where + go !acc i = case i `quot` 10 of + 0 -> acc + q -> go (acc + 1) q +{-# SPECIALIZE numDigits :: Int -> Int #-} +{-# SPECIALIZE numDigits :: Integer -> Int #-} -- | -- diff --git a/Network/Wai/Handler/Warp/Request.hs b/Network/Wai/Handler/Warp/Request.hs --- a/Network/Wai/Handler/Warp/Request.hs +++ b/Network/Wai/Handler/Warp/Request.hs @@ -81,6 +81,7 @@ let idxhdr = indexRequestHeader hdr expect = reqidxExpect idxhdr handle100Continue = handleExpect conn httpversion expect + checkHost httpversion idxhdr (rbody, remainingRef, bodyLength) <- bodyAndSource src idxhdr -- body producing function which will produce '100-continue', if needed rbody' <- timeoutBody remainingRef th rbody handle100Continue @@ -137,6 +138,19 @@ data NoKeepAliveRequest = NoKeepAliveRequest deriving (Show) instance Exception NoKeepAliveRequest + +---------------------------------------------------------------- + +-- | Refusing a request whose @Host@ RFC 9112 section 3.2 refuses. +-- +-- A proxy routes on the first @Host@ and an application reads +-- 'requestHeaderHost', the last of them: a repeated one is a way to +-- reach a virtual host the proxy would not have routed to. +checkHost :: H.HttpVersion -> IndexedRequestHeader -> IO () +checkHost httpversion idxhdr + | reqidxHostRepeated idxhdr = throwIO BadHost + | httpversion >= H.http11, isNothing (reqidxHost idxhdr) = throwIO BadHost + | otherwise = return () ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/RequestHeader.hs b/Network/Wai/Handler/Warp/RequestHeader.hs --- a/Network/Wai/Handler/Warp/RequestHeader.hs +++ b/Network/Wai/Handler/Warp/RequestHeader.hs @@ -7,6 +7,7 @@ import Control.Exception (throwIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C8 (unpack) +import qualified Data.ByteString.Unsafe as SU import Data.ByteString.Internal (memchr) import qualified Data.CaseInsensitive as CI import Data.Word8 @@ -160,26 +161,36 @@ -- @S.any@ with a two-way lambda does. hasControl bs = S.elem _cr bs || S.elem _nul bs --- | The characters RFC 9110 allows in a header field name. +-- | Whether RFC 9110 allows the character in a header field name. +-- +-- One lookup, where a chain of ranges and an 'elem' over fifteen bytes +-- used to be. isTchar :: Word8 -> Bool -isTchar w = - isAsciiUpper w - || isAsciiLower w - || isDigit w - || w - `elem` [ _exclam - , _numbersign - , _dollar - , _percent - , _ampersand - , _quotesingle - , _asterisk - , _plus - , _hyphen - , _period - , _circum - , _underscore - , _grave - , _bar - , _tilde - ] +isTchar w = SU.unsafeIndex tchars (fromIntegral w) == 1 + +-- | 'isTchar' for every byte there is. +tchars :: ByteString +tchars = S.pack $ map tchar [minBound .. maxBound] + where + tchar w + | isAsciiUpper w || isAsciiLower w || isDigit w = 1 + | w `elem` symbols = 1 + | otherwise = 0 + symbols = + [ _exclam + , _numbersign + , _dollar + , _percent + , _ampersand + , _quotesingle + , _asterisk + , _plus + , _hyphen + , _period + , _circum + , _underscore + , _grave + , _bar + , _tilde + ] +{-# NOINLINE tchars #-} diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -61,6 +61,10 @@ | -- | A chunked request body that does not keep to the framing -- RFC 9112 gives it. Since 3.4.17 BadChunkedBody + | -- | No @Host@ in a HTTP\/1.1 request, or more than one, which + -- a router and this server may read differently. + -- Since 3.4.19 + BadHost deriving (Eq) instance Show InvalidRequest where @@ -79,6 +83,7 @@ show BadHeaderLine = "Warp: CR or NUL in a header field line" show (BadFieldName n) = "Warp: Invalid header field name: " ++ show n show BadChunkedBody = "Warp: Malformed chunked request body" + show BadHost = "Warp: Missing or repeated Host" instance E.Exception InvalidRequest diff --git a/test/FileSpec.hs b/test/FileSpec.hs --- a/test/FileSpec.hs +++ b/test/FileSpec.hs @@ -130,3 +130,29 @@ "gives the entire body and ignores the Range header if the condition isn't met" [("If-Range", farPast), ("Range", "bytes=2-7")] regularBody + -- A range which asks for nothing the file holds. The first + -- of these used to be a negative length, which left the + -- request answered with nothing at all. + testFileRange + "returns a 416 for a range which begins past the end" + [("Range", "bytes=100-")] + $ WithoutBody status416 + testFileRange + "returns a 416 for a range which begins at the end" + [("Range", "bytes=16-")] + $ WithoutBody status416 + testFileRange + "returns a 416 for a suffix of no bytes" + [("Range", "bytes=-0")] + $ WithoutBody status416 + -- RFC 9110, section 14.1.2: a suffix longer than the file asks + -- for the whole of it, which is not a range at all and so is a + -- 200 rather than a 206. + testFileRange + "gives the whole file for a suffix longer than it is" + [("Range", "bytes=-100")] + regularBody + testFileRange + "gives the whole file for a suffix exactly as long as it is" + [("Range", "bytes=-16")] + regularBody diff --git a/test/HTTP2Spec.hs b/test/HTTP2Spec.hs new file mode 100644 --- /dev/null +++ b/test/HTTP2Spec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HTTP2Spec (spec) where + +import Control.Exception (bracket, throwIO) +import Data.ByteString (ByteString) +import Data.IORef +import Network.HTTP.Types (Status, ok200, status200) +import qualified Network.HTTP2.Client as C +import Network.Socket +import Network.Wai +import Network.Wai.Handler.Warp ( + Port, + defaultSettings, + setLogger, + setOnException, + withApplicationSettings, + ) +import Test.Hspec + +spec :: Spec +spec = describe "http2server" $ + it "keeps the response of an application which throws after it" $ do + excs <- newIORef (0 :: Int) + logged <- newIORef [] + let settings = + setLogger (\_ st _ -> modifyIORef' logged (st :)) $ + setOnException (\_ _ -> modifyIORef' excs (+ 1)) defaultSettings + withApplicationSettings settings (pure app) $ \port -> do + get port `shouldReturn` (Just ok200, "hello") + readIORef excs `shouldReturn` 1 + -- The second response used to go out and be logged, so the + -- log said 500 where the client had been answered 200. + readIORef logged `shouldReturn` [ok200] + +-- | Answers, then throws. The response has gone out by then, so +-- nothing can replace it. +app :: Application +app _ respond = do + _ <- respond $ responseLBS status200 [] "hello" + throwIO $ userError "after the response" + +-- | The status and body of one h2c request. +get :: Port -> IO (Maybe Status, ByteString) +get port = withTCP "127.0.0.1" port $ \sock -> + bracket (C.allocSimpleConfig sock 4096) C.freeSimpleConfig $ \conf -> + C.run cliconf conf $ \sendRequest _aux -> + sendRequest (C.requestNoBody "GET" "/" []) $ \rsp -> do + body <- C.getResponseBodyChunk rsp + return (C.responseStatus rsp, body) + where + cliconf = C.defaultClientConfig{C.authority = "127.0.0.1"} + +-- | Connect to a TCP server, run an action, and close the socket afterwards. +withTCP :: HostName -> Port -> (Socket -> IO a) -> IO a +withTCP host port = bracket open close + where + open = do + addr : _ <- getAddrInfo (Just defaultHints{addrSocketType = Stream}) (Just host) (Just (show port)) + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + connect sock (addrAddress addr) + return sock diff --git a/test/PackIntSpec.hs b/test/PackIntSpec.hs --- a/test/PackIntSpec.hs +++ b/test/PackIntSpec.hs @@ -12,3 +12,9 @@ prop "" $ \(QC.Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral (n' :: Int) == C8.pack (show n') + -- Every power of ten from 10^15 up used to be written into a buffer + -- one byte too small for it. + it "writes a number of any size" $ + let ns = [10 ^ e + d | e <- [0 .. 40 :: Int], d <- [-1, 0, 1 :: Integer]] + in map packIntegral (filter (>= 0) ns) + `shouldBe` map (C8.pack . show) (filter (>= 0) ns) diff --git a/test/ResponseSpec.hs b/test/ResponseSpec.hs --- a/test/ResponseSpec.hs +++ b/test/ResponseSpec.hs @@ -16,6 +16,22 @@ main :: IO () main = hspec spec +testUnsatisfiable + :: S.ByteString + -- ^ range value + -> Spec +testUnsatisfiable range = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "GET / HTTP/1.0\r\n" + msWrite ms "Range: bytes=" + msWrite ms range + msWrite ms "\r\n\r\n" + threadDelay 10000 + bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 + head bss `shouldContain` "416" + where + app _ = ($ responseFile status200 [] "attic/hex" Nothing) + title = show range ++ " is not satisfiable" + testRange :: S.ByteString -- ^ range value @@ -88,7 +104,11 @@ testRange "5-" "56789abcdef" $ Just "5-15/16" testRange "5-8" "5678" $ Just "5-8/16" testRange "-3" "def" $ Just "13-15/16" - testRange "16-" "" $ Just "*/16" + -- A range which asks for nothing the file holds is 416, not a + -- 206 of no bytes. "bytes */16" is the 416 form of the header. + testUnsatisfiable "16-" + testUnsatisfiable "100-" + testUnsatisfiable "-0" testRange "-17" "0123456789abcdef" Nothing describe "partial files" $ do diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -292,11 +292,11 @@ headers `shouldBe` [] it "no space between colon and value" $ do appWithSocket $ \iheaders ms -> do - let input = "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" + let input = "GET / HTTP/1.1\r\nHost: foo\r\nfoo:bar\r\n\r\n" msWrite ms input threadDelay 5000 headers <- I.readIORef iheaders - headers `shouldBe` [("foo", "bar")] + headers `shouldBe` [("Host", "foo"), ("foo", "bar")] it "refuses multiline headers split across writes" $ do appWithSocket $ \iheaders ms -> do msWrite ms "GET / HTTP/1.1\r\nfoo: and\r\n" @@ -318,9 +318,9 @@ withApp defaultSettings app $ withMySocket $ \ms -> do let input = S.concat - [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" + [ "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n" , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n" - , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" + , "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n" , "b\r\nHello World\r\n0\r\n\r\n" ] msWrite ms input @@ -344,7 +344,7 @@ let input = concat $ replicate 2 $ - ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] + ["POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++ replicate 50 "5\r\n12345\r\n" ++ ["0\r\n\r\n"] mapM_ (msWrite ms) input @@ -374,9 +374,9 @@ withApp defaultSettings app $ withMySocket $ \ms -> do let input = S.concat - [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" + [ "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n" , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n" - , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" + , "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n" , "b\r\nHello World\r\n0\r\n\r\n" ] mapM_ (msWrite ms . S.singleton) $ S.unpack input @@ -412,7 +412,7 @@ let bs1 = S.replicate 2048 88 bs2 = "This is short" bs = S.append bs1 bs2 - msWrite ms "POST / HTTP/1.1\r\n" + msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\n" msWrite ms "content-length: " msWrite ms $ S8.pack $ show $ S.length bs msWrite ms "\r\n\r\n" @@ -574,7 +574,7 @@ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do - msWrite ms "POST / HTTP/1.1\r\nTransfer-Encoding: chunked \r\n\r\n" + msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: chunked \r\n\r\n" msWrite ms "b\r\nHello World\r\n0\r\n\r\n" _ <- msRead ms 17 front <- I.readIORef ifront @@ -614,6 +614,34 @@ "refuses an empty field name" ": 36\r\n" + describe "Host" $ do + -- A proxy routes on the first Host and the application reads the + -- last, so a request they can read differently is refused rather + -- than served to whichever host warp happens to pick. + let send req = do + ihosts <- I.newIORef id + let app r f = do + I.atomicModifyIORef ihosts $ \front -> + (front . (requestHeaderHost r :), ()) + f $ responseLBS status200 [] "" + withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms req + rsp <- msRead ms 17 + hosts <- I.readIORef ihosts + return (S8.unpack rsp, hosts []) + it "refuses a HTTP/1.1 request without one" $ do + (rsp, hosts) <- send "GET /nohost HTTP/1.1\r\n\r\n" + rsp `shouldContain` "400" + hosts `shouldBe` [] + it "refuses more than one" $ do + (rsp, hosts) <- send "GET /dup HTTP/1.1\r\nHost: a\r\nHost: b\r\n\r\n" + rsp `shouldContain` "400" + hosts `shouldBe` [] + it "serves a HTTP/1.0 request without one" $ do + (rsp, hosts) <- send "GET /nohost HTTP/1.0\r\n\r\n" + rsp `shouldContain` "200" + hosts `shouldBe` [Nothing] + describe "malformed chunked bodies" $ do -- The body is what the client says it is up to the empty line -- which ends the trailer section. Each of these used to end the @@ -678,7 +706,7 @@ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do - msWrite ms "POST / HTTP/1.1\r\nTransfer-Encoding: chunked\r\n\r\n" + msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: chunked\r\n\r\n" forM_ ["1", "2", "\r\n", S.replicate 0x12 65, "\r\n0\r\n\r\n"] $ \piece -> threadDelay 50000 >> msWrite ms piece _ <- msRead ms 17 @@ -698,7 +726,7 @@ loop doubleBS = S.concatMap $ \w -> S.pack [w, w] withApp defaultSettings app $ withMySocket $ \ms -> do - msWrite ms "POST / HTTP/1.1\r\n\r\n12345" + msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\n\r\n12345" timeout 100000 (msRead ms 10) `shouldReturn` Just "1122334455" msWrite ms "67890" timeout 100000 (msRead ms 10) `shouldReturn` Just "6677889900" @@ -731,7 +759,7 @@ loop loop withApp defaultSettings app $ withMySocket $ \ms -> do - msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n" + msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\ntransfer-encoding: chunked\r\n\r\n" threadDelay 10000 msWrite ms "5\r\nhello\r\n0\r\n\r\n" atomically $ do diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: warp -version: 3.4.18 +version: 3.4.19 license: MIT license-file: LICENSE maintainer: michael@snoyman.com @@ -189,6 +189,7 @@ FileSpec GracefulShutdownSpec HTTP + HTTP2Spec PackIntSpec ReadIntSpec RequestSpec