From b508227a6ccfd6659d78795a7ae995499c7146ac Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Thu, 4 Jan 2024 04:27:38 +0100
Subject: [PATCH 01/20] warp: changed CRLF parsing logic to avoid unnecessary
 bytestring copying

---
 warp/Network/Wai/Handler/Warp/Request.hs      | 153 +++++++++---------
 .../Network/Wai/Handler/Warp/RequestHeader.hs |   5 +
 warp/Network/Wai/Handler/Warp/Settings.hs     |   6 +-
 3 files changed, 83 insertions(+), 81 deletions(-)

diff --git a/warp/Network/Wai/Handler/Warp/Request.hs b/warp/Network/Wai/Handler/Warp/Request.hs
index a4b2987ba..3cf55ca56 100644
--- a/warp/Network/Wai/Handler/Warp/Request.hs
+++ b/warp/Network/Wai/Handler/Warp/Request.hs
@@ -18,6 +18,7 @@ module Network.Wai.Handler.Warp.Request (
 import qualified Control.Concurrent as Conc (yield)
 import Data.Array ((!))
 import qualified Data.ByteString as S
+import qualified Data.ByteString.Builder as B
 import qualified Data.ByteString.Unsafe as SU
 import qualified Data.CaseInsensitive as CI
 import qualified Data.IORef as I
@@ -236,7 +237,7 @@ timeoutBody remainingRef timeoutHandle rbody handle100Continue = do
 
 ----------------------------------------------------------------
 
-type BSEndo = ByteString -> ByteString
+type BSEndo = B.Builder -> B.Builder
 type BSEndoList = [ByteString] -> [ByteString]
 
 data THStatus
@@ -253,88 +254,86 @@ 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'
+push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
     -- Too many bytes
     | currentTotal > maxTotalHeaderLength = throwIO OverLargeHeader
-    | otherwise = push' mNL
+    | otherwise =
+        case S.elemIndex _lf bs of
+            -- No newline found
+            Nothing -> withNewChunk noNewlineFound
+            -- Newline found at index 'ix'
+            Just ix -> newlineFound ix
   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
+    isWS c = c == _space || c == _tab
+    {-# INLINE finishUp #-}
+    finishUp rest = do
+        when (not $ S.null rest) $ leftoverSource src rest
+        pure $ reqLines []
+    {-# 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 finishUp bs'
+                else do
+                    rest <- if S.length newChunk == 1
+                        -- new chunk is only LF, we need more to check for multiline
+                        then withNewChunk pure
+                        else pure bs'
+                    let nextIsWS = isWS $ SU.unsafeHead rest
+                        status = addEither nextIsWS (bsLen + 1) (SU.unsafeTake (bsLen - 1) bs)
+                    push maxTotalHeaderLength src status rest
+        -- chunk and keep going
+        | otherwise = push maxTotalHeaderLength src (addChunk bsLen bs) newChunk
+    {-# INLINE newlineFound #-}
+    newlineFound ix
+        -- Is end of headers
+        | startsWithLF && chunkLen == 0 =
+            finishUp (SU.unsafeDrop end bs)
+        | otherwise = do
+            -- LF is on last byte
+            rest <- if end == bsLen
+                -- we need more chunks to check for whitespace
+                then withNewChunk pure
+                else pure $ SU.unsafeDrop end bs
+            let nextIsWS = isWS $ SU.unsafeHead rest
+                status = addEither nextIsWS end (SU.unsafeTake (checkCR bs ix) bs)
+            push maxTotalHeaderLength src status rest
       where
-        start = end + 1 -- start of next chunk
-        line = SU.unsafeTake (checkCR bs end) bs
+        end = ix + 1
+        startsWithLF =
+            case ix of
+                0 -> True
+                1 -> SU.unsafeHead bs == _cr
+                _ -> False
+    addEither p =
+        if p then addChunk else addLine
+    -- addLine: take the current chunk and add to 'lines' as optimal as possible
+    addLine len chunk =
+        let newTotal = currentTotal + len
+            newLine =
+                if chunkLen == 0
+                    then chunk
+                    else S.toStrict $ B.toLazyByteString $ prepend $ B.byteString chunk
+         in THStatus newTotal 0 (reqLines . (newLine:)) id
+    -- addChunk: take the current chunk and add to 'prepend' as optimal as possible
+    addChunk len chunk =
+        let newChunkTotal = chunkLen + len
+            newPrepend = prepend . (B.byteString chunk <>)
+         in THStatus totalLen newChunkTotal reqLines newPrepend
+{- HLint ignore push "Use unless" -}
 
 {-# INLINE checkCR #-}
 checkCR :: ByteString -> Int -> Int
diff --git a/warp/Network/Wai/Handler/Warp/RequestHeader.hs b/warp/Network/Wai/Handler/Warp/RequestHeader.hs
index 1caf79dd6..3a0e4390a 100644
--- a/warp/Network/Wai/Handler/Warp/RequestHeader.hs
+++ b/warp/Network/Wai/Handler/Warp/RequestHeader.hs
@@ -63,6 +63,11 @@ parseRequestLine
         , H.HttpVersion
         )
 parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do
+    -- FIXME: Is this still correct with 'HTTP/2' also being valid?
+    -- @
+    -- GET / HTTP/2
+    -- @
+    -- This is 12 characters long
     when (len < 14) $ throwIO baderr
     let methodptr = ptr `plusPtr` off
         limptr = methodptr `plusPtr` len
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.

From c96efd09e18e9edea4be876a8739b272e50db31f Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Thu, 4 Jan 2024 04:28:16 +0100
Subject: [PATCH 02/20] warp/test: added extra tests to make sure the
 'headerLines' parsing is/stays correct

---
 warp/test/RequestSpec.hs |  1 +
 warp/test/RunSpec.hs     | 51 ++++++++++++++++++++++------------------
 2 files changed, 29 insertions(+), 23 deletions(-)

diff --git a/warp/test/RequestSpec.hs b/warp/test/RequestSpec.hs
index f3e6c7522..a099d871f 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
diff --git a/warp/test/RunSpec.hs b/warp/test/RunSpec.hs
index 9e93f87d2..cec1734d8 100644
--- a/warp/test/RunSpec.hs
+++ b/warp/test/RunSpec.hs
@@ -266,21 +266,24 @@ 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
@@ -288,21 +291,23 @@ spec = do
                     `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")
-                               ]
+                headers `shouldBe`
+                    [ ("foo", "bar")
+                    ]
+        it "recognizes 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", "and baz as well")
+                    ]
 
     describe "chunked bodies" $ do
         it "works" $ do

From 1b6c7fdb887febeecf5e60881a22e241b30a11b2 Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Thu, 4 Jan 2024 04:33:27 +0100
Subject: [PATCH 03/20] warp: added entry to ChangeLog

---
 warp/ChangeLog.md | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/warp/ChangeLog.md b/warp/ChangeLog.md
index 2e4b65d45..e59544564 100644
--- a/warp/ChangeLog.md
+++ b/warp/ChangeLog.md
@@ -1,5 +1,10 @@
 # ChangeLog for warp
 
+## 3.3.32
+
+* Reworked header lines (CRLF) parsing to not unnecessarily copy bytestrings.
+   [####](https://github.com/yesodweb/wai/pulls)
+
 ## 3.3.31
 
 * Supporting http2 v5.0.

From 4ba768b25d0611d7471ac2f734640f1a8db71699 Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Thu, 4 Jan 2024 04:59:15 +0100
Subject: [PATCH 04/20] warp: use 'isMultiline' instead of 'p' and inline
 'addLine'

---
 warp/Network/Wai/Handler/Warp/Request.hs | 20 ++++++++++----------
 1 file changed, 10 insertions(+), 10 deletions(-)

diff --git a/warp/Network/Wai/Handler/Warp/Request.hs b/warp/Network/Wai/Handler/Warp/Request.hs
index 3cf55ca56..7c9437d79 100644
--- a/warp/Network/Wai/Handler/Warp/Request.hs
+++ b/warp/Network/Wai/Handler/Warp/Request.hs
@@ -318,16 +318,16 @@ push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
                 0 -> True
                 1 -> SU.unsafeHead bs == _cr
                 _ -> False
-    addEither p =
-        if p then addChunk else addLine
-    -- addLine: take the current chunk and add to 'lines' as optimal as possible
-    addLine len chunk =
-        let newTotal = currentTotal + len
-            newLine =
-                if chunkLen == 0
-                    then chunk
-                    else S.toStrict $ B.toLazyByteString $ prepend $ B.byteString chunk
-         in THStatus newTotal 0 (reqLines . (newLine:)) id
+    addEither isMultiline len chunk
+        | isMultiline = addChunk len chunk
+        -- addLine: take the current chunk and add to 'lines' as optimal as possible
+        | otherwise =
+            let newTotal = currentTotal + len
+                toBS = S.toStrict . B.toLazyByteString
+                newLine =
+                    if chunkLen == 0 then chunk else toBS $ prepend $ B.byteString chunk
+            in THStatus newTotal 0 (reqLines . (newLine:)) id
+    {-# INLINE addChunk #-}
     -- addChunk: take the current chunk and add to 'prepend' as optimal as possible
     addChunk len chunk =
         let newChunkTotal = chunkLen + len

From fb65204377175c313f2469ca2fb4316ba710371b Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sun, 14 Jan 2024 00:22:43 +0100
Subject: [PATCH 05/20] warp/test: calculate length instead of hardcoding

---
 warp/test/RequestSpec.hs | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/warp/test/RequestSpec.hs b/warp/test/RequestSpec.hs
index a099d871f..45ee3454b 100644
--- a/warp/test/RequestSpec.hs
+++ b/warp/test/RequestSpec.hs
@@ -105,16 +105,19 @@ spec = do
             y <- headerLines defaultMaxTotalHeaderLength True src
             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
         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"]

From 5376ae2408bcf9bc0b643b35c011c4cd822cbdcf Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sun, 14 Jan 2024 00:36:23 +0100
Subject: [PATCH 06/20] warp/test: rewrote some tests and added a stupid but
 valid one too

---
 warp/test/RequestSpec.hs | 45 ++++++++++++++++------------------------
 1 file changed, 18 insertions(+), 27 deletions(-)

diff --git a/warp/test/RequestSpec.hs b/warp/test/RequestSpec.hs
index 45ee3454b..c2ba44fd7 100644
--- a/warp/test/RequestSpec.hs
+++ b/warp/test/RequestSpec.hs
@@ -68,44 +68,35 @@ 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"]
 
-        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 a stupid case (3)" $
+            parseHeaderLine $
+                (S8.pack . (:[])) <$> "Status: 200\r\nContent-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
+            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"]
 
-
         -- 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

From 4d8d43bfc58e43c3d2ea3fdd601febd62fc27538 Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sun, 14 Jan 2024 03:58:25 +0100
Subject: [PATCH 07/20] removed unnecessary FIXME

---
 warp/Network/Wai/Handler/Warp/RequestHeader.hs | 5 -----
 1 file changed, 5 deletions(-)

diff --git a/warp/Network/Wai/Handler/Warp/RequestHeader.hs b/warp/Network/Wai/Handler/Warp/RequestHeader.hs
index 3a0e4390a..1caf79dd6 100644
--- a/warp/Network/Wai/Handler/Warp/RequestHeader.hs
+++ b/warp/Network/Wai/Handler/Warp/RequestHeader.hs
@@ -63,11 +63,6 @@ parseRequestLine
         , H.HttpVersion
         )
 parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do
-    -- FIXME: Is this still correct with 'HTTP/2' also being valid?
-    -- @
-    -- GET / HTTP/2
-    -- @
-    -- This is 12 characters long
     when (len < 14) $ throwIO baderr
     let methodptr = ptr `plusPtr` off
         limptr = methodptr `plusPtr` len

From 910117d448c3e775fc889e35b643c6f14ed4983d Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sun, 14 Jan 2024 22:08:36 +0100
Subject: [PATCH 08/20] warp: removed checking for multiline headers and
 inlined a few things

---
 warp/Network/Wai/Handler/Warp/ReadInt.hs |  2 +
 warp/Network/Wai/Handler/Warp/Request.hs | 91 ++++++++++--------------
 2 files changed, 40 insertions(+), 53 deletions(-)

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 7c9437d79..3ed1c8187 100644
--- a/warp/Network/Wai/Handler/Warp/Request.hs
+++ b/warp/Network/Wai/Handler/Warp/Request.hs
@@ -24,7 +24,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
@@ -83,10 +83,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)
@@ -94,12 +97,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
@@ -160,26 +158,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
@@ -268,11 +263,6 @@ push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
   where
     bsLen = S.length bs
     currentTotal = totalLen + chunkLen
-    isWS c = c == _space || c == _tab
-    {-# INLINE finishUp #-}
-    finishUp rest = do
-        when (not $ S.null rest) $ leftoverSource src rest
-        pure $ reqLines []
     {-# INLINE withNewChunk #-}
     withNewChunk :: (S.ByteString -> IO a) -> IO a
     withNewChunk f = do
@@ -286,30 +276,39 @@ push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
             let bs' = SU.unsafeDrop 1 newChunk
              in if bsLen == 1 && chunkLen == 0
                 -- first part is only CRLF, we're done
-                then finishUp bs'
+                then do
+                    when (not $ S.null bs') $ leftoverSource src bs'
+                    pure $ reqLines []
                 else do
                     rest <- if S.length newChunk == 1
                         -- new chunk is only LF, we need more to check for multiline
                         then withNewChunk pure
                         else pure bs'
-                    let nextIsWS = isWS $ SU.unsafeHead rest
-                        status = addEither nextIsWS (bsLen + 1) (SU.unsafeTake (bsLen - 1) bs)
+                    let status = addLine (bsLen + 1) (SU.unsafeTake (bsLen - 1) bs)
                     push maxTotalHeaderLength src status rest
         -- chunk and keep going
-        | otherwise = push maxTotalHeaderLength src (addChunk bsLen bs) newChunk
+        | otherwise = do
+            let newChunkTotal = chunkLen + bsLen
+                newPrepend = prepend . (B.byteString bs <>)
+                status = THStatus totalLen newChunkTotal reqLines newPrepend
+            push maxTotalHeaderLength src status newChunk
     {-# INLINE newlineFound #-}
     newlineFound ix
         -- Is end of headers
-        | startsWithLF && chunkLen == 0 =
-            finishUp (SU.unsafeDrop end bs)
+        | startsWithLF && chunkLen == 0 =  do
+            let rest = SU.unsafeDrop end bs
+            when (not $ S.null rest) $ leftoverSource src rest
+            pure $ reqLines []
         | otherwise = do
             -- LF is on last byte
             rest <- if end == bsLen
                 -- we need more chunks to check for whitespace
                 then withNewChunk pure
                 else pure $ SU.unsafeDrop end bs
-            let nextIsWS = isWS $ SU.unsafeHead rest
-                status = addEither nextIsWS end (SU.unsafeTake (checkCR bs ix) bs)
+            let p = ix - 1
+                chunk =
+                    if ix > 0 && SU.unsafeIndex bs p == _cr then p else ix
+                status = addLine end (SU.unsafeTake chunk bs)
             push maxTotalHeaderLength src status rest
       where
         end = ix + 1
@@ -318,30 +317,16 @@ push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
                 0 -> True
                 1 -> SU.unsafeHead bs == _cr
                 _ -> False
-    addEither isMultiline len chunk
-        | isMultiline = addChunk len chunk
-        -- addLine: take the current chunk and add to 'lines' as optimal as possible
-        | otherwise =
-            let newTotal = currentTotal + len
-                toBS = S.toStrict . B.toLazyByteString
-                newLine =
-                    if chunkLen == 0 then chunk else toBS $ prepend $ B.byteString chunk
-            in THStatus newTotal 0 (reqLines . (newLine:)) id
-    {-# INLINE addChunk #-}
-    -- addChunk: take the current chunk and add to 'prepend' as optimal as possible
-    addChunk len chunk =
-        let newChunkTotal = chunkLen + len
-            newPrepend = prepend . (B.byteString chunk <>)
-         in THStatus totalLen newChunkTotal reqLines newPrepend
+    -- addLine: take the current chunk and, if there's nothing to prepend,
+    -- add straight to 'reqLines', otherwise first prepend then add.
+    addLine len chunk =
+        let newTotal = currentTotal + len
+            toBS = S.toStrict . B.toLazyByteString
+            newLine =
+                if chunkLen == 0 then chunk else toBS $ prepend $ B.byteString chunk
+        in THStatus newTotal 0 (reqLines . (newLine:)) id
 {- HLint ignore push "Use unless" -}
 
-{-# INLINE checkCR #-}
-checkCR :: ByteString -> Int -> Int
-checkCR bs pos
-    | pos > 0 && S.index bs p == _cr = p
-    | otherwise = pos
-  where
-    !p = pos - 1
 
 pauseTimeoutKey :: Vault.Key (IO ())
 pauseTimeoutKey = unsafePerformIO Vault.newKey

From 35639895f258583740c5fe390836b4ec1f6426e1 Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sun, 14 Jan 2024 22:08:59 +0100
Subject: [PATCH 09/20] warp/test: adjusted tests to confirm that multiline
 headers are not supported anymore

I checked the parsing of headers functions and we apparently do not throw or abort
on any invalid header formats. Do we want to do that? Or do we defer that judgement
to any user of 'warp'?
---
 warp/test/RequestSpec.hs | 12 +++++++-----
 warp/test/RunSpec.hs     | 17 +++++++++--------
 2 files changed, 16 insertions(+), 13 deletions(-)

diff --git a/warp/test/RequestSpec.hs b/warp/test/RequestSpec.hs
index c2ba44fd7..4bf51b70f 100644
--- a/warp/test/RequestSpec.hs
+++ b/warp/test/RequestSpec.hs
@@ -80,22 +80,24 @@ spec = do
             parseHeaderLine ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"]
 
         it "can handle a nasty case (2)" $ do
-            parseHeaderLine ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"]
+            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"]
+            parseHeaderLine
+                ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"]
 
         it "can handle a stupid case (3)" $
             parseHeaderLine $
-                (S8.pack . (:[])) <$> "Status: 200\r\nContent-Type: text/plain\r\n\r\n"
+                (S8.pack . (: [])) <$> "Status: 200\r\nContent-Type: text/plain\r\n\r\n"
 
-        it "can handle an illegal case (1)" $ do
+        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"]
diff --git a/warp/test/RunSpec.hs b/warp/test/RunSpec.hs
index cec1734d8..ab80e9215 100644
--- a/warp/test/RunSpec.hs
+++ b/warp/test/RunSpec.hs
@@ -288,7 +288,9 @@ spec = do
                 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
             appWithSocket $ \iheaders ms -> do
@@ -296,18 +298,17 @@ spec = do
                 msWrite ms input
                 threadDelay 5000
                 headers <- I.readIORef iheaders
-                headers `shouldBe`
-                    [ ("foo", "bar")
-                    ]
-        it "recognizes multiline headers" $ do
+                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", "and baz as well")
-                    ]
+                headers
+                    `shouldBe` [ ("foo", "and")
+                               , (" baz as well", "")
+                               ]
 
     describe "chunked bodies" $ do
         it "works" $ do

From dd33dffae0ecb30b3f0bc3c4c2474b2b5a9142a7 Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sun, 14 Jan 2024 22:39:52 +0100
Subject: [PATCH 10/20] enabled more for nightly CI

---
 stack-nightly.yaml | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 deletions(-)

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

From 545e4f1f242d3eeeb25dbddb29b3eb30c7407b5c Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sun, 14 Jan 2024 22:59:12 +0100
Subject: [PATCH 11/20] warp: adjusted 'Request.hs' to build with 'bytestring <
 0.11' and removed 'BangPatterns'

---
 warp/Network/Wai/Handler/Warp/Request.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/warp/Network/Wai/Handler/Warp/Request.hs b/warp/Network/Wai/Handler/Warp/Request.hs
index 3ed1c8187..600825d7d 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 #-}
@@ -19,6 +18,7 @@ import qualified Control.Concurrent as Conc (yield)
 import Data.Array ((!))
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Builder as B
+import qualified Data.ByteString.Lazy as BL (toStrict)
 import qualified Data.ByteString.Unsafe as SU
 import qualified Data.CaseInsensitive as CI
 import qualified Data.IORef as I
@@ -237,8 +237,8 @@ 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
 
@@ -321,7 +321,7 @@ push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
     -- add straight to 'reqLines', otherwise first prepend then add.
     addLine len chunk =
         let newTotal = currentTotal + len
-            toBS = S.toStrict . B.toLazyByteString
+            toBS = BL.toStrict . B.toLazyByteString
             newLine =
                 if chunkLen == 0 then chunk else toBS $ prepend $ B.byteString chunk
         in THStatus newTotal 0 (reqLines . (newLine:)) id

From 6fdc53764486d51486dd1257d32ce81d1c148dbf Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Wed, 17 Jan 2024 00:45:57 +0100
Subject: [PATCH 12/20] fix building warp

---
 stack.yaml      | 2 +-
 warp/warp.cabal | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

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/warp/warp.cabal b/warp/warp.cabal
index 88a385830..ef627d848 100644
--- a/warp/warp.cabal
+++ b/warp/warp.cabal
@@ -139,7 +139,7 @@ Test-Suite spec
                      ExceptionSpec
                      FdCacheSpec
                      FileSpec
-                     PackIntSpec
+                    --  PackIntSpec
                      ReadIntSpec
                      RequestSpec
                      ResponseHeaderSpec

From 4e0af41a1937f7275b6db7f4030531509de4905d Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Wed, 17 Jan 2024 00:53:11 +0100
Subject: [PATCH 13/20] updated Changelog and version

---
 warp/ChangeLog.md | 6 ++++--
 warp/warp.cabal   | 2 +-
 2 files changed, 5 insertions(+), 3 deletions(-)

diff --git a/warp/ChangeLog.md b/warp/ChangeLog.md
index e59544564..290820c46 100644
--- a/warp/ChangeLog.md
+++ b/warp/ChangeLog.md
@@ -2,8 +2,10 @@
 
 ## 3.3.32
 
-* Reworked header lines (CRLF) parsing to not unnecessarily copy bytestrings.
-   [####](https://github.com/yesodweb/wai/pulls)
+* 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
 
diff --git a/warp/warp.cabal b/warp/warp.cabal
index ef627d848..6c6f4b1dd 100644
--- a/warp/warp.cabal
+++ b/warp/warp.cabal
@@ -1,5 +1,5 @@
 Name:                warp
-Version:             3.3.31
+Version:             3.3.32
 Synopsis:            A fast, light-weight web server for WAI applications.
 License:             MIT
 License-file:        LICENSE

From df4cdb8ae40a4edd4717b0a3486e2d37eed2c29a Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sat, 20 Jan 2024 21:46:13 +0100
Subject: [PATCH 14/20] changed version bump to 3.4.0

---
 warp/ChangeLog.md | 2 +-
 warp/warp.cabal   | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/warp/ChangeLog.md b/warp/ChangeLog.md
index 290820c46..73d2b9393 100644
--- a/warp/ChangeLog.md
+++ b/warp/ChangeLog.md
@@ -1,6 +1,6 @@
 # ChangeLog for warp
 
-## 3.3.32
+## 3.4.0
 
 * Reworked request lines (`CRLF`) parsing: [#968](https://github.com/yesodweb/wai/pulls)
     * We do not accept multiline headers anymore.
diff --git a/warp/warp.cabal b/warp/warp.cabal
index 6c6f4b1dd..8dce53dda 100644
--- a/warp/warp.cabal
+++ b/warp/warp.cabal
@@ -1,5 +1,5 @@
 Name:                warp
-Version:             3.3.32
+Version:             3.4.0
 Synopsis:            A fast, light-weight web server for WAI applications.
 License:             MIT
 License-file:        LICENSE

From 559088c16686084e70fbc212c6e08b024d011c5f Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sat, 20 Jan 2024 21:50:15 +0100
Subject: [PATCH 15/20] warp/bench: added benchmark for 'headerLines' to see if
 we're making things better or worse

---
 warp/bench/Parser.hs | 97 ++++++++++++++++++++++++++++++++++----------
 1 file changed, 75 insertions(+), 22 deletions(-)

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"
+        ]

From a1da994270f7aefcc969af2835360cda51f0759b Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sat, 20 Jan 2024 21:50:52 +0100
Subject: [PATCH 16/20] warp/test: small tweak/addition

---
 warp/test/RequestSpec.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/warp/test/RequestSpec.hs b/warp/test/RequestSpec.hs
index 4bf51b70f..6eafe3b2d 100644
--- a/warp/test/RequestSpec.hs
+++ b/warp/test/RequestSpec.hs
@@ -78,6 +78,7 @@ spec = do
 
         it "can handle a nasty case (1)" $ do
             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 (2)" $ do
             parseHeaderLine
@@ -89,7 +90,7 @@ spec = do
 
         it "can handle a stupid case (3)" $
             parseHeaderLine $
-                (S8.pack . (: [])) <$> "Status: 200\r\nContent-Type: text/plain\r\n\r\n"
+                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"]
@@ -99,10 +100,10 @@ spec = do
             y <- headerLines defaultMaxTotalHeaderLength True src
             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 testLength True src

From b672a02b5c518089e58f36e7e5f26533a9e18915 Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sat, 20 Jan 2024 21:51:58 +0100
Subject: [PATCH 17/20] warp: don't use 'ByteString.Builder' for 'push', as
 it's twice as slow, and some more tweaks to improve performance

---
 warp/Network/Wai/Handler/Warp/Request.hs | 41 ++++++++++++------------
 warp/warp.cabal                          | 17 ++++++++--
 2 files changed, 35 insertions(+), 23 deletions(-)

diff --git a/warp/Network/Wai/Handler/Warp/Request.hs b/warp/Network/Wai/Handler/Warp/Request.hs
index 600825d7d..0b51d4a68 100644
--- a/warp/Network/Wai/Handler/Warp/Request.hs
+++ b/warp/Network/Wai/Handler/Warp/Request.hs
@@ -17,8 +17,6 @@ module Network.Wai.Handler.Warp.Request (
 import qualified Control.Concurrent as Conc (yield)
 import Data.Array ((!))
 import qualified Data.ByteString as S
-import qualified Data.ByteString.Builder as B
-import qualified Data.ByteString.Lazy as BL (toStrict)
 import qualified Data.ByteString.Unsafe as SU
 import qualified Data.CaseInsensitive as CI
 import qualified Data.IORef as I
@@ -232,7 +230,7 @@ timeoutBody remainingRef timeoutHandle rbody handle100Continue = do
 
 ----------------------------------------------------------------
 
-type BSEndo = B.Builder -> B.Builder
+type BSEndo = S.ByteString -> S.ByteString
 type BSEndoList = [ByteString] -> [ByteString]
 
 data THStatus
@@ -252,14 +250,16 @@ close = throwIO IncompleteHeaders
 -- | Assumes the 'ByteString' is never 'S.null'
 push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]
 push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
-    -- Too many bytes
-    | currentTotal > maxTotalHeaderLength = throwIO OverLargeHeader
-    | otherwise =
-        case S.elemIndex _lf bs of
-            -- No newline found
-            Nothing -> withNewChunk noNewlineFound
-            -- Newline found at index 'ix'
-            Just ix -> newlineFound ix
+    -- 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
     bsLen = S.length bs
     currentTotal = totalLen + chunkLen
@@ -280,7 +280,7 @@ push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
                     when (not $ S.null bs') $ leftoverSource src bs'
                     pure $ reqLines []
                 else do
-                    rest <- if S.length newChunk == 1
+                    rest <- if S.null bs'
                         -- new chunk is only LF, we need more to check for multiline
                         then withNewChunk pure
                         else pure bs'
@@ -289,27 +289,26 @@ push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
         -- chunk and keep going
         | otherwise = do
             let newChunkTotal = chunkLen + bsLen
-                newPrepend = prepend . (B.byteString bs <>)
+                newPrepend = prepend . (bs <>)
                 status = THStatus totalLen newChunkTotal reqLines newPrepend
             push maxTotalHeaderLength src status newChunk
     {-# INLINE newlineFound #-}
     newlineFound ix
         -- Is end of headers
-        | startsWithLF && chunkLen == 0 =  do
+        | 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
-            rest <- if end == bsLen
-                -- we need more chunks to check for whitespace
-                then withNewChunk pure
-                else pure $ SU.unsafeDrop end bs
             let p = ix - 1
                 chunk =
                     if ix > 0 && SU.unsafeIndex bs p == _cr then p else ix
                 status = addLine end (SU.unsafeTake chunk bs)
-            push maxTotalHeaderLength src status rest
+                continue = push maxTotalHeaderLength src status
+            if end == bsLen
+                then withNewChunk continue
+                else continue $ SU.unsafeDrop end bs
       where
         end = ix + 1
         startsWithLF =
@@ -319,11 +318,11 @@ push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs
                 _ -> 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
-            toBS = BL.toStrict . B.toLazyByteString
             newLine =
-                if chunkLen == 0 then chunk else toBS $ prepend $ B.byteString chunk
+                if chunkLen == 0 then chunk else prepend chunk
         in THStatus newTotal 0 (reqLines . (newLine:)) id
 {- HLint ignore push "Use unless" -}
 
diff --git a/warp/warp.cabal b/warp/warp.cabal
index 8dce53dda..11d9ff3d9 100644
--- a/warp/warp.cabal
+++ b/warp/warp.cabal
@@ -139,7 +139,6 @@ Test-Suite spec
                      ExceptionSpec
                      FdCacheSpec
                      FileSpec
-                    --  PackIntSpec
                      ReadIntSpec
                      RequestSpec
                      ResponseHeaderSpec
@@ -238,27 +237,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

From c59dff573137d55a0f7fa7f31fab718361d83dbf Mon Sep 17 00:00:00 2001
From: Felix Paulusma <felix.paulusma@gmail.com>
Date: Sat, 20 Jan 2024 22:13:29 +0100
Subject: [PATCH 18/20] of course let stuff depending on 'warp' accept the new
 version

---
 wai-app-static/wai-app-static.cabal | 2 +-
 warp-tls/warp-tls.cabal             | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

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

From cb46cf6c5ca55953f2b02a862503f3d43c4ccaa0 Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Mon, 22 Jan 2024 10:04:42 +0900
Subject: [PATCH 19/20] adding PackIntSpec

---
 warp/warp.cabal | 1 +
 1 file changed, 1 insertion(+)

diff --git a/warp/warp.cabal b/warp/warp.cabal
index 11d9ff3d9..2c32f3a80 100644
--- a/warp/warp.cabal
+++ b/warp/warp.cabal
@@ -139,6 +139,7 @@ Test-Suite spec
                      ExceptionSpec
                      FdCacheSpec
                      FileSpec
+                     PackIntSpec
                      ReadIntSpec
                      RequestSpec
                      ResponseHeaderSpec

From b3071655e3bc509c75c4ccbff5146b26db17a5d1 Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Mon, 22 Jan 2024 10:06:05 +0900
Subject: [PATCH 20/20] sorting

---
 warp/warp.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/warp/warp.cabal b/warp/warp.cabal
index 2c32f3a80..a8522fe64 100644
--- a/warp/warp.cabal
+++ b/warp/warp.cabal
@@ -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