From f6e50d47c6a81847e72baf296b8bc7ad5830adcb Mon Sep 17 00:00:00 2001
From: Jonas Collberg <jonas.collberg@scrive.com>
Date: Tue, 5 May 2026 09:56:37 +0200
Subject: [PATCH] Fix consumeChunks: actually strip chunk size-lines and
 trailing CRLFs

Previously consumeChunks returned the raw chunked stream unchanged, so
any caller using Transfer-Encoding: chunked input got chunk-size hex
prefixes embedded in the body. Multipart parsing in particular saw
hex digits inside the file content and rejected the upload.

This fixes consumeChunks/consumeChunksImpl to extract just the chunk
body bytes (dropping the size-line and trailing CRLF), and to drop
the HTTP trailer from the body output (trailers are headers per
RFC 2616, not body content). consumeChunks is also exported from
Internal.Handler so it can be tested.
---
 src/Happstack/Server/Internal/Handler.hs | 25 ++++++++++++++++--------
 tests/Happstack/Server/Tests.hs          | 17 ++++++++++++++++
 2 files changed, 34 insertions(+), 8 deletions(-)

diff --git a/src/Happstack/Server/Internal/Handler.hs b/src/Happstack/Server/Internal/Handler.hs
index 5e4c7b1..9daac5f 100644
--- a/src/Happstack/Server/Internal/Handler.hs
+++ b/src/Happstack/Server/Internal/Handler.hs
@@ -4,6 +4,7 @@ module Happstack.Server.Internal.Handler
     ( request
     , parseResponse
     , putRequest
+    , consumeChunks
     ) where
 
 import qualified Paths_happstack_server as Paths
@@ -154,24 +155,32 @@ parseResponse inputStr =
                  mbCL
        return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags ContentLength,rsValidator=Nothing}
 
--- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html
--- note this does NOT handle extenions
-consumeChunks::L.ByteString->(L.ByteString,L.ByteString)
-consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest)
+-- | Decode an HTTP/1.1 Transfer-Encoding: chunked body.
+-- See http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html (chunk extensions are not handled).
+-- Returns @(decoded body, bytes following the chunked stream)@. The trailer (optional headers
+-- after the terminating 0-chunk, RFC 2616 §3.6.1) is dropped from the body — trailers are
+-- headers, not body content.
+consumeChunks :: L.ByteString -> (L.ByteString, L.ByteString)
+consumeChunks str = let (parts,_tr,rest) = consumeChunksImpl str in (L.concat . map snd $ parts, rest)
 
+-- | Worker for 'consumeChunks'. Returns @(chunks, trailer, remainder)@, where each chunk is
+-- @(declared-length, body-bytes)@ and the terminating 0-chunk has empty body.
 consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)
 consumeChunksImpl str
     | L.null str = ([],L.empty,str)
-    | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str
+    | chunkLen == 0 = let (_sizeLine,rest') = L.splitAt lenLine1 str
                           (tr',rest'') = getTrailer rest'
-                      in ([(0,last)],tr',rest'')
-    | otherwise = ((chunkLen,part):crest,tr,rest2)
+                      in ([(0,L.empty)],tr',rest'')
+    | otherwise = ((chunkLen,body):crest,tr,rest2)
     where
       line1 = head $ lazylines str
       lenLine1 = (L.length line1) + 1 -- endchar
       chunkLen = (fst $ head $ readHex $ L.unpack line1)
       len = chunkLen + lenLine1 + 2
-      (part,rest) = L.splitAt len str
+      -- Each frame on the wire is "<hex-size>\r\n<body-bytes>\r\n". Skip the size-line and
+      -- take exactly chunkLen bytes so the trailing CRLF stays out of the decoded body.
+      (frame,rest) = L.splitAt len str
+      body = L.take chunkLen . L.drop lenLine1 $ frame
       (crest,tr,rest2) = consumeChunksImpl rest
       getTrailer s = L.splitAt index s
           where index | crlfLC `L.isPrefixOf` s = 2
diff --git a/tests/Happstack/Server/Tests.hs b/tests/Happstack/Server/Tests.hs
index 009e678..b7c2bbe 100644
--- a/tests/Happstack/Server/Tests.hs
+++ b/tests/Happstack/Server/Tests.hs
@@ -19,6 +19,7 @@ import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse)
 import Happstack.Server.Cookie
 import Happstack.Server.Internal.Compression
 import Happstack.Server.Internal.Cookie
+import Happstack.Server.Internal.Handler (consumeChunks)
 import Happstack.Server.Internal.Multipart
 import Happstack.Server.Internal.MessageWrap
 import Happstack.Server.Internal.RFC822Headers (ContentDisposition(..), parseContentDisposition)
@@ -37,6 +38,7 @@ allTests =
                                 , cookieHeaderOrderTest
                                 , pContentDispositionFilename
                                 , applicativeTest
+                                , consumeChunksTest
                                 ]
 
 cookieParserTest :: Test
@@ -251,6 +253,21 @@ pContentDispositionFilename =
        c <- parseContentDisposition doesNotWorkWithOldParserButWithNew
        assertEqual "parseContentDisposition" c (ContentDisposition "form-data" [("filename","file.pdf"),("name","file")])
 
+consumeChunksTest :: Test
+consumeChunksTest =
+  "consumeChunks decodes Transfer-Encoding: chunked" ~:
+    [ -- Single chunk
+      consumeChunks (pack "5\r\nhello\r\n0\r\n\r\n") @?= (pack "hello", pack "")
+      -- Multiple chunks concatenated
+    , consumeChunks (pack "5\r\nhello\r\n5\r\nworld\r\n0\r\n\r\n")
+        @?= (pack "helloworld", pack "")
+      -- Empty body (only terminator)
+    , consumeChunks (pack "0\r\n\r\n") @?= (pack "", pack "")
+      -- Trailing bytes after final chunk are returned as remainder
+    , consumeChunks (pack "5\r\nhello\r\n0\r\n\r\nNEXT")
+        @?= (pack "hello", pack "NEXT")
+    ]
+
 applicativeTest :: Test
 applicativeTest =
   "applicativeTest" ~: