warp 3.4.16 → 3.4.17
raw patch · 9 files changed
+552/−106 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Network.Wai.Handler.Warp: AmbiguousBodyLength :: InvalidRequest
+ Network.Wai.Handler.Warp: BadChunkedBody :: InvalidRequest
+ Network.Wai.Handler.Warp: BadFieldName :: ByteString -> InvalidRequest
+ Network.Wai.Handler.Warp: BadHeaderLine :: InvalidRequest
+ Network.Wai.Handler.Warp: UnsupportedTransferEncoding :: InvalidRequest
Files
- ChangeLog.md +20/−0
- Network/Wai/Handler/Warp/Conduit.hs +94/−63
- Network/Wai/Handler/Warp/Header.hs +11/−2
- Network/Wai/Handler/Warp/Request.hs +72/−18
- Network/Wai/Handler/Warp/RequestHeader.hs +53/−6
- Network/Wai/Handler/Warp/Settings.hs +7/−0
- Network/Wai/Handler/Warp/Types.hs +21/−0
- test/RunSpec.hs +272/−15
- warp.cabal +2/−2
ChangeLog.md view
@@ -1,5 +1,25 @@ # ChangeLog for warp +## 3.4.17++* Security: `Transfer-Encoding` is read as the comma separated list RFC 9112+ defines, and a framing warp and a proxy could read differently is refused.+* Security: a `Content-Length` must be digits which fit in an `Int` and+ repeated ones must agree.+* Security: a header field name must be a non-empty token, which also refuses+ obs-fold continuation lines.+* Security: a bare CR or a NUL in a header field line is refused.+* Security: the chunked body parser keeps to RFC 9112: chunk sizes, the CRLF+ after a chunk, size lines split over several reads, and the trailer section.+* A chunked body cut short by the end of input is now an error rather than a+ body the application is handed as though it were whole.+ [#1129](https://github.com/yesodweb/wai/issues/1129).+* A last chunk must now be followed by the CRLF which ends the trailer+ section, unless the connection ends there.+* `InvalidRequest` gains `UnsupportedTransferEncoding`, `AmbiguousBodyLength`,+ `BadFieldName`, `BadHeaderLine` and `BadChunkedBody`.+* Allow time-manager 0.5.+ ## 3.4.16 * Graceful shutdown no longer stops while a connection it accepted is
Network/Wai/Handler/Warp/Conduit.hs view
@@ -5,7 +5,7 @@ import Control.Exception (assert, throwIO) import qualified Data.ByteString as S import qualified Data.IORef as I-import Data.Word8 (_0, _9, _A, _F, _a, _cr, _f, _lf)+import Data.Word8 (_0, _9, _A, _F, _a, _cr, _f, _lf, _semicolon) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types@@ -78,20 +78,40 @@ ref <- I.newIORef NeedLen return $! CSource src ref +-- | A chunk-size line is a few bytes of hex, and chunk extensions are+-- all but unused; a trailer section is a handful of fields. Neither is+-- a reason to hold on to everything a client cares to send.+maxChunkLineLength :: Int+maxChunkLineLength = 1024++maxTrailerLength :: Int+maxTrailerLength = 8192+ readCSource :: CSource -> IO ByteString readCSource (CSource src ref) = do mlen <- I.readIORef ref go mlen where- withLen 0 bs = do- leftoverSource src bs- dropCRLF- yield' S.empty DoneChunking+ go NeedLen = getLen+ go NeedLenNewline = dropCRLF >> getLen+ go (HaveLen len) = readSource src >>= withLen len+ go DoneChunking = return S.empty++ getLen = do+ len <- chunkSize =<< requireLine+ if len == 0+ then do+ -- Everything up to the empty line which ends the trailer+ -- section belongs to this request. Warp used to drop one+ -- CRLF and leave the trailers in the source, where they+ -- were read as the next request on the connection.+ dropTrailers 0+ yield' S.empty DoneChunking+ else readSource src >>= withLen len+ withLen len bs- | S.null bs = do- -- FIXME should this throw an exception if len > 0?- I.writeIORef ref DoneChunking -- [WRITE_IOREF_NOTE]- return S.empty+ -- The chunk promised more than the client went on to send.+ | S.null bs = throwIO ConnectionClosedByPeer | otherwise = case S.length bs `compare` fromIntegral len of EQ -> yield' bs NeedLenNewline@@ -105,64 +125,75 @@ I.writeIORef ref mlen -- [WRITE_IOREF_NOTE] return bs - dropCRLF = do- bs <- readSource src- case S.uncons bs of- Nothing -> return ()- Just (w8, bs')- | w8 == _cr -> dropLF bs'- | w8 == _lf -> leftoverSource src bs'- | otherwise -> leftoverSource src bs+ -- A chunk size is 1*HEXDIG, with nothing after it but chunk+ -- extensions. Warp used to fold whatever hex digits it could find+ -- and take 0 for the rest, so a line which is no chunk size at all+ -- -- a request line, say -- ended the body and left the rest of it+ -- to be read as the next request.+ chunkSize line+ | S.null digits = throwIO BadChunkedBody+ | not (S.null ext), S.head ext /= _semicolon = throwIO BadChunkedBody+ | otherwise =+ maybe (throwIO BadChunkedBody) (return . fromIntegral) $+ S.foldl' accumulate (Just (0 :: Int)) digits+ where+ (digits, ext) = S.span isHexDigit line+ accumulate Nothing _ = Nothing+ -- A chunk warp cannot measure is a chunk warp cannot read.+ accumulate (Just n) w+ | n > (maxBound - d) `div` 16 = Nothing+ | otherwise = Just $! n * 16 + d+ where+ d = fromIntegral (hexToWord w) - dropLF bs =- case S.uncons bs of- Nothing -> do- bs2 <- readSource' src- unless (S.null bs2) $ dropLF bs2- Just (w8, bs') ->- leftoverSource src $- if w8 == _lf then bs' else bs+ -- The CRLF which ends chunk-data. Warp used to put anything else+ -- back and read it as the next chunk size, so a chunk that was not+ -- closed off ended the body early.+ dropCRLF = do+ line <- requireLine+ unless (S.null line) $ throwIO BadChunkedBody - go NeedLen = getLen- go NeedLenNewline = dropCRLF >> getLen- go (HaveLen 0) = do- -- Drop the final CRLF- dropCRLF- I.writeIORef ref DoneChunking -- [WRITE_IOREF_NOTE]- return S.empty- go (HaveLen len) = do- bs <- readSource src- withLen len bs- go DoneChunking = return S.empty+ dropTrailers total = do+ mline <- readLine+ case mline of+ -- A client which leaves out the last CRLF and closes has+ -- nothing left to hide behind it.+ Nothing -> return ()+ Just line -> unless (S.null line) $ do+ let total' = total + S.length line+ when (total' > maxTrailerLength) $ throwIO OverLargeHeader+ dropTrailers total' - -- Get the length from the source, and then pass off control to withLen- getLen = do- bs <- readSource src- if S.null bs- then do- I.writeIORef ref $ assert False $ HaveLen 0 -- [WRITE_IOREF_NOTE]- return S.empty- else do- (x, y) <-- case S.break (== _lf) bs of- (x, y)- | S.null y -> do- bs2 <- readSource' src- return $- if S.null bs2- then (x, y)- else S.break (== _lf) $ bs `S.append` bs2- | otherwise -> return (x, y)- let w =- S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0 $- S.takeWhile isHexDigit x+ requireLine = readLine >>= maybe (throwIO ConnectionClosedByPeer) return - let y' = S.drop 1 y- y'' <-- if S.null y'- then readSource src- else return y'- withLen w y''+ -- One line of the chunked framing: up to the next LF, without it or+ -- the CR before it, leaving the rest of what was read in the source.+ -- 'Nothing' when the connection ends where a line was to begin.+ -- Warp used to give up one read short of the LF, which mis-read+ -- every size line that arrived in more than two pieces.+ readLine = loop 0 id+ where+ loop total front = do+ bs <- readSource src+ if S.null bs+ then+ if total == 0+ then return Nothing+ else throwIO ConnectionClosedByPeer+ else case S.elemIndex _lf bs of+ Nothing -> do+ let total' = total + S.length bs+ when (total' > maxChunkLineLength) $ throwIO OverLargeHeader+ loop total' (front . (bs :))+ Just ix -> do+ leftoverSource src $ S.drop (ix + 1) bs+ let line = S.concat $ front [S.take ix bs]+ when (S.length line > maxChunkLineLength) $+ throwIO OverLargeHeader+ return $ Just $ dropCR line+ dropCR bs = case S.unsnoc bs of+ Just (bs', w) | w == _cr -> bs'+ _ -> bs hexToWord w | w <= _9 = w - _0
Network/Wai/Handler/Warp/Header.hs view
@@ -51,14 +51,23 @@ | bs == "user-agent" -> ix{reqidxUserAgent = Just val} | bs == "connection" -> ix{reqidxConnection = Just val} 13 | bs == "if-none-match" -> ix{reqidxIfNoneMatch = Just val}- 14 | bs == "content-length" -> ix{reqidxContentLength = Just val}+ 14+ | bs == "content-length" ->+ ix{reqidxContentLength = appendField (reqidxContentLength ix) val} 17- | bs == "transfer-encoding" -> ix{reqidxTransferEncoding = Just val}+ | bs == "transfer-encoding" ->+ ix{reqidxTransferEncoding = appendField (reqidxTransferEncoding ix) val} | bs == "if-modified-since" -> ix{reqidxIfModifiedSince = Just val} 19 | bs == "if-unmodified-since" -> ix{reqidxIfUnmodifiedSince = Just val} _ -> ix where bs = foldedCase key+ -- RFC 9112: repeated field lines are one comma separated list, so+ -- keep them all. Taking the last line alone would let a second+ -- Content-Length hide the length of the first, or a second+ -- Transfer-Encoding its chunked coding.+ appendField Nothing val' = Just val'+ appendField (Just prev) val' = Just $ prev <> "," <> val' -- | 'IndexedRequestHeader' with no headers set. defaultIndexRequestHeader :: IndexedRequestHeader
Network/Wai/Handler/Warp/Request.hs view
@@ -20,7 +20,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.IORef as I import qualified Data.Vault.Lazy as Vault-import Data.Word8 (_cr, _lf)+import Data.Word8 (_0, _comma, _cr, _lf, _space, _tab, isDigit) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif@@ -38,7 +38,6 @@ import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Imports hiding (readInt)-import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.RequestHeader import Network.Wai.Handler.Warp.Settings ( Settings,@@ -165,25 +164,80 @@ , Maybe (I.IORef Int) , RequestBodyLength )-bodyAndSource src idxhdr- | chunked = do- csrc <- mkCSource src- return (readCSource csrc, Nothing, ChunkedBody)- | otherwise = do- let len = toLength $ reqidxContentLength idxhdr- bodyLen = KnownLength $ fromIntegral len- isrc@(ISource _ remaining) <- mkISource src len- return (readISource isrc, Just remaining, bodyLen)+bodyAndSource src idxhdr = do+ framing <- bodyFraming idxhdr+ case framing of+ FramedByChunks -> do+ csrc <- mkCSource src+ return (readCSource csrc, Nothing, ChunkedBody)+ FramedByLength len -> do+ isrc@(ISource _ remaining) <- mkISource src len+ return (readISource isrc, Just remaining, KnownLength $ fromIntegral len)++-- | How the end of the request body is found (RFC 9112, section 6).+data BodyFraming+ = FramedByChunks+ | FramedByLength Int++-- | Deciding how the request body is framed, or refusing the request.+--+-- Anything other than one framing this server and every intermediary+-- agree on is refused rather than read some way of warp's own: whoever+-- reads it the other way sees one request where warp sees two, which is+-- how a request is smuggled past a proxy.+bodyFraming :: IndexedRequestHeader -> IO BodyFraming+bodyFraming idxhdr = case reqidxTransferEncoding idxhdr of+ Nothing -> FramedByLength <$> contentLength (reqidxContentLength idxhdr)+ -- Transfer-Encoding wins over Content-Length, so sending both is a+ -- way of showing each reader the framing it prefers. Take neither.+ Just _ | isJust (reqidxContentLength idxhdr) -> throwIO AmbiguousBodyLength+ Just te -> case reverse $ codings te of+ -- The only coding warp implements, and the only one it can be+ -- sure an intermediary passed on undisturbed.+ ["chunked"] -> return FramedByChunks+ -- Chunked frames the body, but warp decodes no coding under it.+ "chunked" : _ -> throwIO UnsupportedTransferEncoding+ -- Without chunked last, the length cannot be determined at all.+ _ -> throwIO AmbiguousBodyLength where- chunked = isChunked $ reqidxTransferEncoding idxhdr+ -- A comma separated list, each element allowed its own surrounding+ -- whitespace. RFC 9110 has a recipient ignore empty elements, so+ -- "chunked", " chunked" and "chunked," are each the one coding.+ codings =+ filter (not . S.null) . map (CI.foldCase . stripOWS) . S.split _comma -toLength :: Maybe HeaderValue -> Int-toLength Nothing = 0-toLength (Just bs) = readInt bs+-- | The length a Content-Length gives, or no body when there is none.+--+-- RFC 9112 asks for a value of nothing but digits, and for repeated+-- Content-Lengths to be refused unless every one of them says the same+-- thing. Warp used to read the leading digits and take 0 for the rest,+-- so "abc", a value too large for an 'Int', and a second Content-Length+-- hiding the first all became a request with no body at all -- and the+-- bytes that were the body became the next request on the connection.+contentLength :: Maybe HeaderValue -> IO Int+contentLength Nothing = return 0+contentLength (Just bs) = case map (readLength . stripOWS) $ S.split _comma bs of+ Just len : lens | all (== Just len) lens -> return len+ _ -> throwIO AmbiguousBodyLength+ where+ readLength v+ | S.null v || not (S.all isDigit v) = Nothing+ | otherwise = S.foldl' accumulate (Just 0) v+ accumulate Nothing _ = Nothing+ accumulate (Just n) w+ -- A length warp cannot hold is a length warp cannot enforce.+ | n > (maxBound - d) `div` 10 = Nothing+ | otherwise = Just $! n * 10 + d+ where+ d = fromIntegral (w - _0) -isChunked :: Maybe HeaderValue -> Bool-isChunked (Just bs) = CI.foldCase bs == "chunked"-isChunked _ = False+-- | Optional whitespace, which RFC 9112 allows around the elements of a+-- list and gives no meaning to.+stripOWS :: ByteString -> ByteString+stripOWS = fst . S.spanEnd isOWS . S.dropWhile isOWS++isOWS :: Word8 -> Bool+isOWS w = w == _space || w == _tab ----------------------------------------------------------------
Network/Wai/Handler/Warp/RequestHeader.hs view
@@ -37,7 +37,7 @@ parseHeaderLines (firstLine : otherLines) = do (method, path', query, httpversion) <- parseRequestLine firstLine let path = H.extractPath path'- hdr = map parseHeader otherLines+ hdr <- mapM parseHeader otherLines return (method, path', path, query, httpversion, hdr) ----------------------------------------------------------------@@ -131,8 +131,55 @@ -- ("Host","example.com:8080") -- >>> parseHeader "NoSemiColon" -- ("NoSemiColon","")-parseHeader :: ByteString -> H.Header-parseHeader s =- let (k, rest) = S.break (== _colon) s- rest' = S.dropWhile (\c -> c == _space || c == _tab) $ S.drop 1 rest- in (CI.mk k, rest')+-- >>> parseHeader "Content-Length : 47"+-- *** Exception: Warp: Invalid header field name: "Content-Length "+-- >>> parseHeader "X-Foo: a\rContent-Length: 47"+-- *** Exception: Warp: CR or NUL in a header field line+parseHeader :: ByteString -> IO H.Header+parseHeader s = do+ -- The line was ended by an LF, and the CR before it is already+ -- gone, so any CR left here is a bare one. RFC 9110 section 5.5+ -- asks for it to be refused or replaced: a recipient which takes a+ -- bare CR for a line terminator reads a field, and a framing field+ -- among them, where warp reads only data.+ when (hasControl s) $ throwIO BadHeaderLine+ -- RFC 9112 asks for 400 here, because a recipient which instead+ -- repairs the name reads a header where warp reads none: a+ -- Content-Length hidden that way is a request body warp does not+ -- know it is being sent.+ when (S.null k || not (S.all isTchar k)) $ throwIO $ BadFieldName k+ return (CI.mk k, rest')+ where+ (k, rest) = S.break (== _colon) s+ rest' = S.dropWhile isOWS $ S.drop 1 rest+ isOWS c = c == _space || c == _tab+ -- Two passes of memchr beat one pass of a lambda here by a wide+ -- margin, and 'S.elem' is the way to ask for memchr: measured over+ -- a browser's request headers, this takes a fifth of the time that+ -- @S.any (_cr ==)@ does and a fifteenth of the time that one+ -- @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.+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+ ]
Network/Wai/Handler/Warp/Settings.hs view
@@ -404,6 +404,8 @@ -- Sending 413 for too large payload. -- Sending 431 for too large headers. -- @since 3.2.27+-- Sending 501 for an unsupported transfer coding.+-- @since 3.4.17 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e | isAsyncException e = throw e@@ -417,6 +419,11 @@ H.status431 [(H.hContentType, "text/plain; charset=utf-8")] "Request header fields too large"+ | Just UnsupportedTransferEncoding <- fromException e =+ responseLBS+ H.notImplemented501+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Unsupported transfer coding" | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400
Network/Wai/Handler/Warp/Types.hs view
@@ -45,6 +45,22 @@ PayloadTooLarge | -- | Since 3.3.22 RequestHeaderFieldsTooLarge+ | -- | A transfer coding warp does not implement. Since 3.4.17+ UnsupportedTransferEncoding+ | -- | The length of the request body cannot be determined+ -- reliably, so no reading of it can be trusted. Since 3.4.17+ AmbiguousBodyLength+ | -- | CR or NUL inside a header field line, which one reader+ -- takes for a line terminator where another reads data.+ -- Since 3.4.17+ BadHeaderLine+ | -- | A header field name which is not a token, which hides the+ -- field from one reader but not another.+ -- Since 3.4.17+ BadFieldName ByteString+ | -- | A chunked request body that does not keep to the framing+ -- RFC 9112 gives it. Since 3.4.17+ BadChunkedBody deriving (Eq) instance Show InvalidRequest where@@ -58,6 +74,11 @@ show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s show RequestHeaderFieldsTooLarge = "Request header fields too large" show PayloadTooLarge = "Payload too large"+ show UnsupportedTransferEncoding = "Warp: Unsupported transfer coding"+ show AmbiguousBodyLength = "Warp: Ambiguous request body length"+ 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" instance E.Exception InvalidRequest
test/RunSpec.hs view
@@ -200,7 +200,7 @@ singleChunkedPostHello :: [ByteString] singleChunkedPostHello = [ "POST /hello HTTP/1.1\r\nHost: localhost\r\nTransfer-Encoding: chunked\r\n\r\n"- , "5\r\nHello\r\n0\r\n"+ , "5\r\nHello\r\n0\r\n\r\n" ] spec :: Spec@@ -282,17 +282,14 @@ respond $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ f iheaders - it "multiline headers" $ do+ it "refuses multiline headers" $ do appWithSocket $ \iheaders ms -> do let input = "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" msWrite ms input- threadDelay 5000+ rsp <- msRead ms 17 headers <- I.readIORef iheaders- headers- `shouldBe` [ ("foo", "bar")- , (" baz", "")- , ("\tbin", "")- ]+ S8.unpack rsp `shouldContain` "400"+ 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"@@ -300,16 +297,14 @@ threadDelay 5000 headers <- I.readIORef iheaders headers `shouldBe` [("foo", "bar")]- it "does not recognize multiline headers" $ do+ it "refuses multiline headers split across writes" $ do appWithSocket $ \iheaders ms -> do msWrite ms "GET / HTTP/1.1\r\nfoo: and\r\n" msWrite ms " baz as well\r\n\r\n"- threadDelay 5000+ rsp <- msRead ms 17 headers <- I.readIORef iheaders- headers- `shouldBe` [ ("foo", "and")- , (" baz as well", "")- ]+ S8.unpack rsp `shouldContain` "400"+ headers `shouldBe` [] describe "chunked bodies" $ do it "works" $ do@@ -380,7 +375,7 @@ let input = S.concat [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "c\r\nHello World\n\r\n3\r\nBye\r\n0\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" , "b\r\nHello World\r\n0\r\n\r\n" ]@@ -428,6 +423,268 @@ threadDelay 1000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs++ describe "header field values" $ do+ let exchange hdrs = do+ ipaths <- I.newIORef id+ let app req f = do+ I.atomicModifyIORef ipaths $ \front ->+ (front . (rawPathInfo req :), ())+ f $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms $+ S.concat+ [ "POST / HTTP/1.1\r\nHost: foo\r\n"+ , hdrs+ , "\r\nGET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+ ]+ rsp <- msRead ms 17+ ipaths' <- I.readIORef ipaths+ return (S8.unpack rsp, ipaths' [])+ it "refuses a bare CR" $ do+ -- A recipient which ends a line at the bare CR reads a+ -- Content-Length here, and so reads a body where warp would+ -- read the next request.+ (rsp, paths) <- exchange "X-Foo: a\rContent-Length: 36\r\n"+ rsp `shouldContain` "400"+ paths `shouldNotContain` ["/smuggled"]+ it "refuses a NUL" $ do+ (rsp, paths) <- exchange "X-Foo: a\NULb\r\n"+ rsp `shouldContain` "400"+ paths `shouldNotContain` ["/smuggled"]++ describe "Content-Length framing" $ do+ -- A Content-Length warp reads as no body at all, while whatever+ -- is in front of it reads a body, is a request smuggled onto the+ -- connection: the body is read here as the next request.+ let exchange hdrs = do+ ipaths <- I.newIORef id+ let app req f = do+ I.atomicModifyIORef ipaths $ \front ->+ (front . (rawPathInfo req :), ())+ f $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms $+ S.concat+ [ "POST / HTTP/1.1\r\nHost: foo\r\n"+ , hdrs+ , "\r\nGET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+ ]+ rsp <- msRead ms 17+ ipaths' <- I.readIORef ipaths+ return (S8.unpack rsp, ipaths' [])+ refuses name hdrs = it name $ do+ (rsp, paths) <- exchange hdrs+ rsp `shouldContain` "400"+ paths `shouldNotContain` ["/smuggled"]+ refuses+ "refuses a Content-Length that is not a number"+ "Content-Length: abc\r\n"+ refuses+ "refuses a Content-Length that overflows"+ "Content-Length: 9223372036854775808\r\n"+ refuses+ "refuses Content-Lengths that disagree"+ "Content-Length: 0\r\nContent-Length: 36\r\n"+ it "accepts Content-Lengths that agree" $ do+ ifront <- I.newIORef id+ let app req f = do+ bss <- consumeBody $ getRequestBodyChunk req+ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ())+ f $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms $+ S.concat+ [ "POST / HTTP/1.1\r\nHost: foo\r\n"+ , "Content-Length: 5\r\nContent-Length: 05\r\n\r\n"+ , "Hello"+ ]+ _ <- msRead ms 17+ front <- I.readIORef ifront+ front [] `shouldBe` ["Hello"]++ describe "ambiguous body framing" $ do+ -- Each of these frames the body one way for warp and another way+ -- for anything in front of it. Whichever way warp reads them, the+ -- smuggled request must not reach the application.+ let exchange hdrs = do+ ipaths <- I.newIORef id+ let app req f = do+ I.atomicModifyIORef ipaths $ \front ->+ (front . (rawPathInfo req :), ())+ f $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms $+ S.concat+ [ "POST / HTTP/1.1\r\nHost: foo\r\n"+ , hdrs+ , "\r\nGET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+ ]+ rsp <- msRead ms 17+ ipaths' <- I.readIORef ipaths+ return (S8.unpack rsp, ipaths' [])+ frames name hdrs = it name $ do+ (rsp, paths) <- exchange hdrs+ rsp `shouldContain` "200"+ paths `shouldNotContain` ["/smuggled"]+ refuses name hdrs status = it name $ do+ (rsp, paths) <- exchange hdrs+ rsp `shouldContain` status+ paths `shouldNotContain` ["/smuggled"]+ frames+ "reads a trailing space as part of the chunked coding"+ "Transfer-Encoding: chunked \r\n"+ frames+ "reads a trailing tab as part of the chunked coding"+ "Transfer-Encoding: chunked\t\r\n"+ frames+ "ignores an empty element after the chunked coding"+ "Transfer-Encoding: chunked,\r\n"+ frames+ "ignores an empty element before the chunked coding"+ "Transfer-Encoding: , chunked\r\n"+ refuses+ "refuses a Transfer-Encoding with no coding at all"+ "Transfer-Encoding: ,\r\n"+ "400"+ refuses+ "refuses a coding it cannot decode under chunked"+ "Transfer-Encoding: gzip, chunked\r\n"+ "501"+ refuses+ "refuses chunked that is not the final coding"+ "Transfer-Encoding: chunked, gzip\r\n"+ "400"+ refuses+ "refuses a transfer coding that is not chunked"+ "Transfer-Encoding: identity\r\n"+ "400"+ refuses+ "joins Transfer-Encoding field lines before reading them"+ "Transfer-Encoding: chunked\r\nTransfer-Encoding: identity\r\n"+ "400"+ refuses+ "refuses Content-Length together with Transfer-Encoding"+ "Content-Length: 0\r\nTransfer-Encoding: chunked\r\n"+ "400"+ it "still reads an ordinary chunked body" $ do+ ifront <- I.newIORef id+ let app req f = do+ bss <- consumeBody $ getRequestBodyChunk req+ 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 "b\r\nHello World\r\n0\r\n\r\n"+ _ <- msRead ms 17+ front <- I.readIORef ifront+ front [] `shouldBe` ["Hello World"]++ describe "header field names" $ do+ -- Each of these is refused rather than repaired: a recipient+ -- which repairs it reads a body of 36 bytes, which warp would+ -- read as a request of its own.+ let refuses name hdrs = it name $ do+ ipaths <- I.newIORef id+ let app req f = do+ I.atomicModifyIORef ipaths $ \front ->+ (front . (rawPathInfo req :), ())+ f $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms $+ S.concat+ [ "POST / HTTP/1.1\r\nHost: foo\r\n"+ , hdrs+ , "\r\nGET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+ ]+ rsp <- msRead ms 17+ paths <- I.readIORef ipaths+ S8.unpack rsp `shouldContain` "400"+ paths [] `shouldNotContain` ["/smuggled"]+ refuses+ "refuses whitespace between a field name and its colon"+ "Content-Length : 36\r\n"+ refuses+ "refuses a control character in a field name"+ "Content-Length\v: 36\r\n"+ refuses+ "refuses a continuation line"+ "X-Foo: bar\r\n Content-Length: 36\r\n"+ refuses+ "refuses an empty field name"+ ": 36\r\n"++ 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+ -- body early, leaving the rest of it to be read as the next+ -- request on the connection.+ let withChunked body = do+ ipaths <- I.newIORef id+ let app req f = do+ I.atomicModifyIORef ipaths $ \front ->+ (front . (rawPathInfo req :), ())+ _ <- consumeBody $ getRequestBodyChunk req+ f $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms $+ S.concat+ [ "POST / HTTP/1.1\r\nHost: foo\r\n"+ , "Transfer-Encoding: chunked\r\n\r\n"+ , body+ ]+ rsp <- msRead ms 17+ ipaths' <- I.readIORef ipaths+ return (S8.unpack rsp, ipaths' [])+ smuggled = "GET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+ refuses name body = it name $ do+ (rsp, paths) <- withChunked body+ rsp `shouldContain` "400"+ paths `shouldNotContain` ["/smuggled"]+ refuses "refuses a chunk size that is not a number" smuggled+ refuses+ "refuses a chunk that is not closed off by CRLF"+ (S.concat ["5\r\nHello", smuggled])+ refuses "refuses a chunk size that overflows" "ffffffffffffffffff\r\n"+ it "refuses a chunk cut short by the end of input" $ do+ -- A chunk promising a hundred bytes with ten sent and nothing+ -- more. The body ended there and the application was handed a+ -- short one as though it were whole: yesodweb/wai#1129.+ ref <- I.newIORef Nothing+ let onExc _ = I.writeIORef ref . Just+ app req f = do+ _ <- consumeBody $ getRequestBodyChunk req+ f $ responseLBS status200 [] ""+ withApp (setOnException onExc defaultSettings) app $ withMySocket $ \ms -> do+ msWrite ms $+ S.concat+ [ "POST / HTTP/1.1\r\nHost: foo\r\n"+ , "Transfer-Encoding: chunked\r\n\r\n"+ , "64\r\n"+ , S8.pack (replicate 10 'A')+ ]+ msClose ms+ threadDelay 100000+ res <- I.readIORef ref+ show res `shouldBe` show (Just ConnectionClosedByPeer)+ it "reads the trailer section to its end" $ do+ (rsp, paths) <- withChunked $ S.concat ["0\r\nX-Trailer: y\r\n", smuggled]+ rsp `shouldContain` "200"+ paths `shouldBe` ["/"]+ it "reads a chunk size split over several reads" $ do+ ifront <- I.newIORef id+ let app req f = do+ bss <- consumeBody $ getRequestBodyChunk req+ 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"+ forM_ ["1", "2", "\r\n", S.replicate 0x12 65, "\r\n0\r\n\r\n"] $+ \piece -> threadDelay 50000 >> msWrite ms piece+ _ <- msRead ms 17+ front <- I.readIORef ifront+ front [] `shouldBe` [S.replicate 0x12 65]+ describe "raw body" $ do it "works" $ do let app _req f = do
warp.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: warp-version: 3.4.16+version: 3.4.17 license: MIT license-file: LICENSE maintainer: michael@snoyman.com@@ -115,7 +115,7 @@ stm >=2.3, streaming-commons >=0.1.10, text,- time-manager >=0.2 && <0.5,+ time-manager >=0.2 && <0.6, vault >=0.3, wai >=3.2.5 && <3.3, word8