diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 363c86cdd..2527fef3c 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -8,12 +8,12 @@ packages: - ./wai-app-static - ./wai-conduit - ./wai-extra - # Commented out packages until they are supported on nightly + # Needs 'multipart' to accept 'bytestring < 0.13' # - ./wai-frontend-monadcgi - ./wai-http2-extra - # - ./wai-websockets + - ./wai-websockets - ./warp - # - ./warp-quic + - ./warp-quic - ./warp-tls flags: wai-extra: @@ -23,4 +23,9 @@ nix: packages: - fcgi - zlib -extra-deps: [] +extra-deps: + - crypto-token-0.1.0 + - http3-0.0.7 + - network-udp-0.0.0 + - quic-0.1.15 + - sockaddr-0.0.1 \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index fa0a2248a..9923c3dce 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-22.3 +resolver: lts-22.6 packages: - ./auto-update - ./mime-types diff --git a/wai-app-static/wai-app-static.cabal b/wai-app-static/wai-app-static.cabal index b50d2b4d9..bd92648b5 100644 --- a/wai-app-static/wai-app-static.cabal +++ b/wai-app-static/wai-app-static.cabal @@ -52,7 +52,7 @@ library , filepath , wai-extra >= 3.0 && < 3.2 , optparse-applicative >= 0.7 - , warp >= 3.0.11 && < 3.4 + , warp >= 3.0.11 && < 3.5 if flag(crypton) build-depends: crypton >= 0.6 , memory >= 0.7 diff --git a/warp-tls/warp-tls.cabal b/warp-tls/warp-tls.cabal index e6abed2f3..ff013c425 100644 --- a/warp-tls/warp-tls.cabal +++ b/warp-tls/warp-tls.cabal @@ -21,7 +21,7 @@ Library Build-Depends: base >= 4.12 && < 5 , bytestring >= 0.9 , wai >= 3.2 && < 3.3 - , warp >= 3.3.29 && < 3.4 + , warp >= 3.3.29 && < 3.5 , data-default-class >= 0.0.1 , tls >= 1.7 , network >= 2.2.1 diff --git a/warp/ChangeLog.md b/warp/ChangeLog.md index 2e4b65d45..73d2b9393 100644 --- a/warp/ChangeLog.md +++ b/warp/ChangeLog.md @@ -1,5 +1,12 @@ # ChangeLog for warp +## 3.4.0 + +* Reworked request lines (`CRLF`) parsing: [#968](https://github.com/yesodweb/wai/pulls) + * We do not accept multiline headers anymore. + ([`RFC 7230`](https://www.rfc-editor.org/rfc/rfc7230#section-3.2.4) deprecated it 10 years ago) + * Reworked request lines (`CRLF`) parsing to not unnecessarily copy bytestrings. + ## 3.3.31 * Supporting http2 v5.0. diff --git a/warp/Network/Wai/Handler/Warp/ReadInt.hs b/warp/Network/Wai/Handler/Warp/ReadInt.hs index 24a44b0ed..1b9e5834e 100644 --- a/warp/Network/Wai/Handler/Warp/ReadInt.hs +++ b/warp/Network/Wai/Handler/Warp/ReadInt.hs @@ -15,6 +15,8 @@ import Data.Word8 (isDigit, _0) import Network.Wai.Handler.Warp.Imports hiding (readInt) {-# INLINE readInt #-} + +-- | Will 'takeWhile isDigit' and return the parsed 'Integral'. readInt :: Integral a => ByteString -> a readInt bs = fromIntegral $ readInt64 bs diff --git a/warp/Network/Wai/Handler/Warp/Request.hs b/warp/Network/Wai/Handler/Warp/Request.hs index a4b2987ba..0b51d4a68 100644 --- a/warp/Network/Wai/Handler/Warp/Request.hs +++ b/warp/Network/Wai/Handler/Warp/Request.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} @@ -23,7 +22,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.IORef as I import Data.Typeable (Typeable) import qualified Data.Vault.Lazy as Vault -import Data.Word8 (_cr, _lf, _space, _tab) +import Data.Word8 (_cr, _lf) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif @@ -82,10 +81,13 @@ recvRequest firstRequest settings conn ii th addr src transport = do parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr expect = idxhdr ! fromEnum ReqExpect - cl = idxhdr ! fromEnum ReqContentLength - te = idxhdr ! fromEnum ReqTransferEncoding handle100Continue = handleExpect conn httpversion expect - rawPath = if settingsNoParsePath settings then unparsedPath else path + (rbody, remainingRef, bodyLength) <- bodyAndSource src idxhdr + -- body producing function which will produce '100-continue', if needed + rbody' <- timeoutBody remainingRef th rbody handle100Continue + -- body producing function which will never produce 100-continue + rbodyFlush <- timeoutBody remainingRef th rbody (return ()) + let rawPath = if settingsNoParsePath settings then unparsedPath else path vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) . Vault.insert getFileInfoKey (getFileInfo ii) @@ -93,12 +95,7 @@ recvRequest firstRequest settings conn ii th addr src transport = do . Vault.insert getClientCertificateKey (getTransportClientCertificate transport) #endif $ Vault.empty - (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te - -- body producing function which will produce '100-continue', if needed - rbody' <- timeoutBody remainingRef th rbody handle100Continue - -- body producing function which will never produce 100-continue - rbodyFlush <- timeoutBody remainingRef th rbody (return ()) - let req = + req = Request { requestMethod = method , httpVersion = httpversion @@ -159,26 +156,23 @@ handleExpect _ _ _ = return () bodyAndSource :: Source - -> Maybe HeaderValue - -- ^ content length - -> Maybe HeaderValue - -- ^ transfer-encoding + -> IndexedHeader -> IO ( IO ByteString , Maybe (I.IORef Int) , RequestBodyLength ) -bodyAndSource src cl te +bodyAndSource src idxhdr | chunked = do csrc <- mkCSource src return (readCSource csrc, Nothing, ChunkedBody) | otherwise = do + let len = toLength $ idxhdr ! fromEnum ReqContentLength + bodyLen = KnownLength $ fromIntegral len isrc@(ISource _ remaining) <- mkISource src len return (readISource isrc, Just remaining, bodyLen) where - len = toLength cl - bodyLen = KnownLength $ fromIntegral len - chunked = isChunked te + chunked = isChunked $ idxhdr ! fromEnum ReqTransferEncoding toLength :: Maybe HeaderValue -> Int toLength Nothing = 0 @@ -236,13 +230,13 @@ timeoutBody remainingRef timeoutHandle rbody handle100Continue = do ---------------------------------------------------------------- -type BSEndo = ByteString -> ByteString +type BSEndo = S.ByteString -> S.ByteString type BSEndoList = [ByteString] -> [ByteString] data THStatus = THStatus - !Int -- running total byte count (excluding current header chunk) - !Int -- current header chunk byte count + Int -- running total byte count (excluding current header chunk) + Int -- current header chunk byte count BSEndoList -- previously parsed lines BSEndo -- bytestrings to be prepended @@ -253,96 +247,85 @@ close :: Sink ByteString IO a close = throwIO IncompleteHeaders -} +-- | Assumes the 'ByteString' is never 'S.null' push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString] -push maxTotalHeaderLength src (THStatus totalLen chunkLen lines prepend) bs' - -- Too many bytes - | currentTotal > maxTotalHeaderLength = throwIO OverLargeHeader - | otherwise = push' mNL +push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs + -- Newline found at index 'ix' + | Just ix <- S.elemIndex _lf bs = do + -- Too many bytes + when (currentTotal > maxTotalHeaderLength) $ throwIO OverLargeHeader + newlineFound ix + -- No newline found + | otherwise = do + -- Early easy abort + when (currentTotal + bsLen > maxTotalHeaderLength) $ throwIO OverLargeHeader + withNewChunk noNewlineFound where - currentTotal = totalLen + chunkLen - -- bs: current header chunk, plus maybe (parts of) next header - bs = prepend bs' bsLen = S.length bs - -- Maybe newline - -- Returns: Maybe - -- ( length of this chunk up to newline - -- , position of newline in relation to entire current header - -- , is this part of a multiline header - -- ) - mNL = do - chunkNL <- S.elemIndex _lf bs' - let headerNL = chunkNL + S.length (prepend "") - chunkNLlen = chunkNL + 1 - -- check if there are two more bytes in the bs - -- if so, see if the second of those is a horizontal space - if bsLen > headerNL + 1 - then - let c = S.index bs (headerNL + 1) - b = case headerNL of - 0 -> True - 1 -> S.index bs 0 == _cr - _ -> False - isMultiline = not b && (c == _space || c == _tab) - in Just (chunkNLlen, headerNL, isMultiline) - else Just (chunkNLlen, headerNL, False) - - {-# INLINE push' #-} - push' :: Maybe (Int, Int, Bool) -> IO [ByteString] - -- No newline find in this chunk. Add it to the prepend, - -- update the length, and continue processing. - push' Nothing = do - bst <- readSource' src - when (S.null bst) $ throwIO IncompleteHeaders - push maxTotalHeaderLength src status bst - where - prepend' = S.append bs - thisChunkLen = S.length bs' - newChunkLen = chunkLen + thisChunkLen - status = THStatus totalLen newChunkLen lines prepend' - -- Found a newline, but next line continues as a multiline header - push' (Just (chunkNLlen, end, True)) = - push maxTotalHeaderLength src status rest - where - rest = S.drop (end + 1) bs - prepend' = S.append (SU.unsafeTake (checkCR bs end) bs) - -- If we'd just update the entire current chunk up to newline - -- we wouldn't count all the dropped newlines in between. - -- So update 'chunkLen' with current chunk up to newline - -- and use 'chunkLen' later on to add to 'totalLen'. - newChunkLen = chunkLen + chunkNLlen - status = THStatus totalLen newChunkLen lines prepend' - -- Found a newline at position end. - push' (Just (chunkNLlen, end, False)) - -- leftover - | S.null line = do - when (start < bsLen) $ leftoverSource src (SU.unsafeDrop start bs) - return (lines []) - -- more headers - | otherwise = - let lines' = lines . (line :) - newTotalLength = totalLen + chunkLen + chunkNLlen - status = THStatus newTotalLength 0 lines' id - in if start < bsLen - then -- more bytes in this chunk, push again - - let bs'' = SU.unsafeDrop start bs - in push maxTotalHeaderLength src status bs'' - else do - -- no more bytes in this chunk, ask for more - bst <- readSource' src - when (S.null bs) $ throwIO IncompleteHeaders - push maxTotalHeaderLength src status bst + currentTotal = totalLen + chunkLen + {-# INLINE withNewChunk #-} + withNewChunk :: (S.ByteString -> IO a) -> IO a + withNewChunk f = do + newChunk <- readSource' src + when (S.null newChunk) $ throwIO IncompleteHeaders + f newChunk + {-# INLINE noNewlineFound #-} + noNewlineFound newChunk + -- The chunk split the CRLF in half + | SU.unsafeLast bs == _cr && S.head newChunk == _lf = + let bs' = SU.unsafeDrop 1 newChunk + in if bsLen == 1 && chunkLen == 0 + -- first part is only CRLF, we're done + then do + when (not $ S.null bs') $ leftoverSource src bs' + pure $ reqLines [] + else do + rest <- if S.null bs' + -- new chunk is only LF, we need more to check for multiline + then withNewChunk pure + else pure bs' + let status = addLine (bsLen + 1) (SU.unsafeTake (bsLen - 1) bs) + push maxTotalHeaderLength src status rest + -- chunk and keep going + | otherwise = do + let newChunkTotal = chunkLen + bsLen + newPrepend = prepend . (bs <>) + status = THStatus totalLen newChunkTotal reqLines newPrepend + push maxTotalHeaderLength src status newChunk + {-# INLINE newlineFound #-} + newlineFound ix + -- Is end of headers + | chunkLen == 0 && startsWithLF = do + let rest = SU.unsafeDrop end bs + when (not $ S.null rest) $ leftoverSource src rest + pure $ reqLines [] + | otherwise = do + -- LF is on last byte + let p = ix - 1 + chunk = + if ix > 0 && SU.unsafeIndex bs p == _cr then p else ix + status = addLine end (SU.unsafeTake chunk bs) + continue = push maxTotalHeaderLength src status + if end == bsLen + then withNewChunk continue + else continue $ SU.unsafeDrop end bs where - start = end + 1 -- start of next chunk - line = SU.unsafeTake (checkCR bs end) bs - -{-# INLINE checkCR #-} -checkCR :: ByteString -> Int -> Int -checkCR bs pos - | pos > 0 && S.index bs p == _cr = p - | otherwise = pos - where - !p = pos - 1 + end = ix + 1 + startsWithLF = + case ix of + 0 -> True + 1 -> SU.unsafeHead bs == _cr + _ -> False + -- addLine: take the current chunk and, if there's nothing to prepend, + -- add straight to 'reqLines', otherwise first prepend then add. + {-# INLINE addLine #-} + addLine len chunk = + let newTotal = currentTotal + len + newLine = + if chunkLen == 0 then chunk else prepend chunk + in THStatus newTotal 0 (reqLines . (newLine:)) id +{- HLint ignore push "Use unless" -} + pauseTimeoutKey :: Vault.Key (IO ()) pauseTimeoutKey = unsafePerformIO Vault.newKey diff --git a/warp/Network/Wai/Handler/Warp/Settings.hs b/warp/Network/Wai/Handler/Warp/Settings.hs index 8d80b1ae1..dc6715fe8 100644 --- a/warp/Network/Wai/Handler/Warp/Settings.hs +++ b/warp/Network/Wai/Handler/Warp/Settings.hs @@ -302,12 +302,10 @@ defaultFork io = case io unsafeUnmask of IO io' -> case fork# io' s0 of - (# s1, _tid #) -> - (# s1, () #) + (# s1, _tid #) -> (# s1, () #) #else case fork# (io unsafeUnmask) s0 of - (# s1, _tid #) -> - (# s1, () #) + (# s1, _tid #) -> (# s1, () #) #endif -- | Standard "accept" call for a listening socket. diff --git a/warp/bench/Parser.hs b/warp/bench/Parser.hs index 98b4e3102..0c5ec19fb 100644 --- a/warp/bench/Parser.hs +++ b/warp/bench/Parser.hs @@ -1,23 +1,26 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Control.Monad import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as B (unpack) -import Data.Word8 (_H, _P, _T, _period, _slash) -import qualified Network.HTTP.Types as H -import Network.Wai.Handler.Warp.Types -import UnliftIO.Exception (impureThrow, throwIO) -import Prelude hiding (lines) - +import qualified Data.ByteString.Char8 as B (pack, unpack) import Data.ByteString.Internal -import Data.Word +import Data.IORef (atomicModifyIORef', newIORef) +import qualified Data.List as L +import Data.Word8 import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable +import qualified Network.HTTP.Types as H +import UnliftIO.Exception (impureThrow, throwIO) +import Prelude hiding (lines) + +import Network.Wai.Handler.Warp.Request (headerLines) +import Network.Wai.Handler.Warp.Types #if MIN_VERSION_gauge(0, 2, 0) import Gauge @@ -49,7 +52,16 @@ main = do , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2 , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2 ] + , bgroup + "parsing request" + [ bench "new parsing 4" $ whnfAppIO testIt (chunkRequest 4) + , bench "new parsing 10" $ whnfAppIO testIt (chunkRequest 10) + , bench "new parsing 25" $ whnfAppIO testIt (chunkRequest 25) + , bench "new parsing 100" $ whnfAppIO testIt (chunkRequest 100) + ] ] + where + testIt req = producer req >>= headerLines 800 False ---------------------------------------------------------------- @@ -72,15 +84,15 @@ parseRequestLine3 ) parseRequestLine3 requestLine = ret where - (!method, !rest) = S.break (== 32) requestLine -- ' ' + (!method, !rest) = S.break (== _space) requestLine (!pathQuery, !httpVer') | rest == "" = impureThrow badmsg - | otherwise = S.break (== 32) (S.drop 1 rest) -- ' ' - (!path, !query) = S.break (== 63) pathQuery -- '?' + | otherwise = S.break (== _space) (S.drop 1 rest) + (!path, !query) = S.break (== _question) pathQuery !httpVer = S.drop 1 httpVer' (!http, !ver) | httpVer == "" = impureThrow badmsg - | otherwise = S.break (== 47) httpVer -- '/' + | otherwise = S.break (== _slash) httpVer !hv | http /= "HTTP" = impureThrow NonHttp | ver == "/1.1" = H.http11 @@ -114,13 +126,13 @@ parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> limptr = methodptr `plusPtr` len lim0 = fromIntegral len - pathptr0 <- memchr methodptr 32 lim0 -- ' ' + pathptr0 <- memchr methodptr _space lim0 when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $ throwIO baderr let pathptr = pathptr0 `plusPtr` 1 lim1 = fromIntegral (limptr `minusPtr` pathptr0) - httpptr0 <- memchr pathptr 32 lim1 -- ' ' + httpptr0 <- memchr pathptr _space lim1 when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ throwIO baderr let httpptr = httpptr0 `plusPtr` 1 @@ -128,7 +140,7 @@ parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> checkHTTP httpptr !hv <- httpVersion httpptr - queryptr <- memchr pathptr 63 lim2 -- '?' + queryptr <- memchr pathptr _question lim2 let !method = bs ptr methodptr pathptr0 !path | queryptr == nullPtr = bs ptr pathptr httpptr0 @@ -154,7 +166,7 @@ parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> httpVersion httpptr = do major <- peek $ httpptr `plusPtr` 5 minor <- peek $ httpptr `plusPtr` 7 - if major == (49 :: Word8) && minor == (49 :: Word8) + if major == _1 && minor == _1 then return H.http11 else return H.http10 bs ptr p0 p1 = PS fptr o l @@ -183,15 +195,15 @@ parseRequestLine1 , H.HttpVersion ) parseRequestLine1 requestLine = do - let (!method, !rest) = S.break (== 32) requestLine -- ' ' - (!pathQuery, !httpVer') = S.break (== 32) (S.drop 1 rest) -- ' ' + let (!method, !rest) = S.break (== _space) requestLine + (!pathQuery, !httpVer') = S.break (== _space) (S.drop 1 rest) !httpVer = S.drop 1 httpVer' when (rest == "" || httpVer == "") $ throwIO $ BadFirstLine $ B.unpack requestLine - let (!path, !query) = S.break (== 63) pathQuery -- '?' - (!http, !ver) = S.break (== 47) httpVer -- '/' + let (!path, !query) = S.break (== _question) pathQuery + (!http, !ver) = S.break (== _slash) httpVer when (http /= "HTTP") $ throwIO NonHttp let !hv | ver == "/1.1" = H.http11 @@ -219,14 +231,14 @@ parseRequestLine0 , H.HttpVersion ) parseRequestLine0 s = - case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- ' + case filter (not . S.null) $ S.splitWith (\c -> c == _space || c == _tab) s of (method' : query : http'') -> do let !method = method' !http' = S.concat http'' (!hfirst, !hsecond) = S.splitAt 5 http' if hfirst == "HTTP/" then - let (!rpath, !qstring) = S.break (== 63) query -- '?' + let (!rpath, !qstring) = S.break (== _question) query !hv = case hsecond of "1.1" -> H.http11 @@ -234,3 +246,44 @@ parseRequestLine0 s = in return $! (method, rpath, qstring, hv) else throwIO NonHttp _ -> throwIO $ BadFirstLine $ B.unpack s + +producer :: [ByteString] -> IO Source +producer a = do + ref <- newIORef a + mkSource $ + atomicModifyIORef' ref $ \case + [] -> ([], S.empty) + b : bs -> (bs, b) + +chunkRequest :: Int -> [ByteString] +chunkRequest chunkAmount = + go basicRequest + where + len = L.length basicRequest + chunkSize = (len `div` chunkAmount) + 1 + go [] = [] + go xs = + let (a, b) = L.splitAt chunkSize xs + in B.pack a : go b + +-- Random google search request +basicRequest :: String +basicRequest = + mconcat + [ "GET /search?q=test&sca_esv=600090652&source=hp&uact=5&oq=test&sclient=gws-wiz HTTP/3\r\n" + , "Host: www.google.com\r\n" + , "User-Agent: Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:121.0) Gecko/20100101 Firefox/121.0\r\n" + , "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,*/*;q=0.8\r\n" + , "Accept-Language: en-US,en;q=0.5\r\n" + , "Accept-Encoding: gzip, deflate, br\r\n" + , "Referer: https://www.google.com/\r\n" + , "Alt-Used: www.google.com\r\n" + , "Connection: keep-alive\r\n" + , "Cookie: CONSENT=PENDING+252\r\n" + , "Upgrade-Insecure-Requests: 1\r\n" + , "Sec-Fetch-Dest: document\r\n" + , "Sec-Fetch-Mode: navigate\r\n" + , "Sec-Fetch-Site: same-origin\r\n" + , "Sec-Fetch-User: ?1\r\n" + , "TE: trailers\r\n\r\n" + ] diff --git a/warp/test/RequestSpec.hs b/warp/test/RequestSpec.hs index f3e6c7522..6eafe3b2d 100644 --- a/warp/test/RequestSpec.hs +++ b/warp/test/RequestSpec.hs @@ -6,6 +6,7 @@ module RequestSpec (main, spec) where import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.IORef +import Data.Monoid (Sum (..)) import qualified Network.HTTP.Types.Header as HH import Network.Wai.Handler.Warp.File (parseByteRanges) import Network.Wai.Handler.Warp.Request @@ -67,53 +68,50 @@ spec = do test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1] describe "headerLines" $ do - it "can handle a normal case" $ do - src <- - mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource - x <- headerLines defaultMaxTotalHeaderLength True src - x `shouldBe` ["Status: 200", "Content-Type: text/plain"] + let parseHeaderLine chunks = do + src <- mkSourceFunc chunks >>= mkSource + x <- headerLines defaultMaxTotalHeaderLength True src + x `shouldBe` ["Status: 200", "Content-Type: text/plain"] - it "can handle a nasty case (1)" $ do - src <- - mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] - >>= mkSource - x <- headerLines defaultMaxTotalHeaderLength True src - x `shouldBe` ["Status: 200", "Content-Type: text/plain"] + it "can handle a normal case" $ + parseHeaderLine ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] it "can handle a nasty case (1)" $ do - src <- - mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] - >>= mkSource - x <- headerLines defaultMaxTotalHeaderLength True src - x `shouldBe` ["Status: 200", "Content-Type: text/plain"] + parseHeaderLine ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] + parseHeaderLine ["Status: 200\r\n", "Content-Type: text/plain", "\r\n\r\n"] - it "can handle a nasty case (1)" $ do - src <- - mkSourceFunc - ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] - >>= mkSource - x <- headerLines defaultMaxTotalHeaderLength True src - x `shouldBe` ["Status: 200", "Content-Type: text/plain"] + it "can handle a nasty case (2)" $ do + parseHeaderLine + ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] + + it "can handle a nasty case (3)" $ do + parseHeaderLine + ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] - it "can handle an illegal case (1)" $ do - src <- - mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] - >>= mkSource + it "can handle a stupid case (3)" $ + parseHeaderLine $ + S8.pack . (: []) <$> "Status: 200\r\nContent-Type: text/plain\r\n\r\n" + + it "can (not) handle an illegal case (1)" $ do + let chunks = ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] + src <- mkSourceFunc chunks >>= mkSource x <- headerLines defaultMaxTotalHeaderLength True src x `shouldBe` [] y <- headerLines defaultMaxTotalHeaderLength True src - y `shouldBe` ["Status: 200", "Content-Type: text/plain"] + y `shouldBe` ["Status:", " 200", "Content-Type: text/plain"] - -- Length is 39, this shouldn't fail let testLengthHeaders = ["Sta", "tus: 200\r", "\n", "Content-Type: ", "text/plain\r\n\r\n"] + headerLength = getSum $ foldMap (Sum . S.length) testLengthHeaders + testLength = headerLength - 2 -- Because the second CRLF at the end isn't counted + -- Length is 39, this shouldn't fail it "doesn't throw on correct length" $ do src <- mkSourceFunc testLengthHeaders >>= mkSource - x <- headerLines 39 True src + x <- headerLines testLength True src x `shouldBe` ["Status: 200", "Content-Type: text/plain"] -- Length is still 39, this should fail it "throws error on correct length too long" $ do src <- mkSourceFunc testLengthHeaders >>= mkSource - headerLines 38 True src `shouldThrow` (== OverLargeHeader) + headerLines (testLength - 1) True src `shouldThrow` (== OverLargeHeader) where blankSafe = headerLinesList ["f", "oo\n", "bar\nbaz\n\r\n"] whiteSafe = headerLinesList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"] diff --git a/warp/test/RunSpec.hs b/warp/test/RunSpec.hs index 9e93f87d2..ab80e9215 100644 --- a/warp/test/RunSpec.hs +++ b/warp/test/RunSpec.hs @@ -266,42 +266,48 @@ spec = do it "double connect" $ runTest 1 doubleConnect [singlePostHello] describe "connection termination" $ do - -- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello" - it "IncompleteHeaders" $ + -- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello" + it "IncompleteHeaders" $ do + runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r" runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n" + runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r" + runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-lengt" describe "special input" $ do + let appWithSocket f = do + iheaders <- I.newIORef [] + let app req respond = do + liftIO $ I.writeIORef iheaders $ requestHeaders req + respond $ responseLBS status200 [] "" + withApp defaultSettings app $ withMySocket $ f iheaders + it "multiline headers" $ do - iheaders <- I.newIORef [] - let app req f = do - liftIO $ I.writeIORef iheaders $ requestHeaders req - f $ responseLBS status200 [] "" - withApp defaultSettings app $ withMySocket $ \ms -> do - let input = - S.concat - [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" - ] + 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 headers <- I.readIORef iheaders headers - `shouldBe` [ ("foo", "bar baz\tbin") + `shouldBe` [ ("foo", "bar") + , (" baz", "") + , ("\tbin", "") ] it "no space between colon and value" $ do - iheaders <- I.newIORef [] - let app req f = do - liftIO $ I.writeIORef iheaders $ requestHeaders req - f $ responseLBS status200 [] "" - withApp defaultSettings app $ withMySocket $ \ms -> do - let input = - S.concat - [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" - ] + appWithSocket $ \iheaders ms -> do + let input = "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" msWrite ms input threadDelay 5000 headers <- I.readIORef iheaders + headers `shouldBe` [("foo", "bar")] + it "does not recognize multiline headers" $ 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 + headers <- I.readIORef iheaders headers - `shouldBe` [ ("foo", "bar") + `shouldBe` [ ("foo", "and") + , (" baz as well", "") ] describe "chunked bodies" $ do diff --git a/warp/warp.cabal b/warp/warp.cabal index 88a385830..a8522fe64 100644 --- a/warp/warp.cabal +++ b/warp/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.3.31 +Version: 3.4.0 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -139,6 +139,7 @@ Test-Suite spec ExceptionSpec FdCacheSpec FileSpec + HTTP PackIntSpec ReadIntSpec RequestSpec @@ -147,7 +148,6 @@ Test-Suite spec RunSpec SendFileSpec WithApplicationSpec - HTTP Network.Wai.Handler.Warp Network.Wai.Handler.Warp.Buffer Network.Wai.Handler.Warp.Conduit @@ -238,27 +238,41 @@ Test-Suite spec Benchmark parser Type: exitcode-stdio-1.0 Main-Is: Parser.hs - other-modules: Network.Wai.Handler.Warp.Date + other-modules: Network.Wai.Handler.Warp.Conduit + Network.Wai.Handler.Warp.Date Network.Wai.Handler.Warp.FdCache Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HashMap + Network.Wai.Handler.Warp.Header Network.Wai.Handler.Warp.Imports Network.Wai.Handler.Warp.MultiMap + Network.Wai.Handler.Warp.ReadInt + Network.Wai.Handler.Warp.Request + Network.Wai.Handler.Warp.RequestHeader + Network.Wai.Handler.Warp.Settings Network.Wai.Handler.Warp.Types + Paths_warp HS-Source-Dirs: bench . Build-Depends: base >= 4.8 && < 5 + , array , auto-update , bytestring + , case-insensitive , containers , gauge + , ghc-prim , hashable , http-date , http-types , network , network , recv + , streaming-commons + , text , time-manager , unliftio + , vault + , wai , word8 if flag(x509) Build-Depends: crypton-x509