Merge PR yesodweb#781.

warp/ChangeLog.md

@@ -1,3 +1,8 @@
+## 3.3.8
+
+* Maximum header size is configurable.
+  [#781](https://github.com/yesodweb/wai/pull/781)
+
 ## 3.3.7
 
 * InvalidArgument (Bad file descriptor) is ignored in `receive`.

warp/Network/Wai/Handler/Warp.hs

@@ -74,6 +74,7 @@ module Network.Wai.Handler.Warp (
   , setGracefulShutdownTimeout
   , setGracefulCloseTimeout1
   , setGracefulCloseTimeout2
+  , setMaxTotalHeaderLength
     -- ** Getters
   , getPort
   , getHost
@@ -436,6 +437,13 @@ setGracefulShutdownTimeout :: Maybe Int
                            -> Settings -> Settings
 setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }
 
+-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.
+--
+-- Since 3.3.8
+setMaxTotalHeaderLength :: Int -> Settings -> Settings
+setMaxTotalHeaderLength maxTotalHeaderLength settings = settings
+  { settingsMaxTotalHeaderLength = maxTotalHeaderLength }
+
 -- | Explicitly pause the slowloris timeout.
 --
 -- This is useful for cases where you partially consume a request body. For

warp/Network/Wai/Handler/Warp/Request.hs

@@ -38,13 +38,7 @@ import Network.Wai.Handler.Warp.Header
 import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)
 import Network.Wai.Handler.Warp.ReadInt
 import Network.Wai.Handler.Warp.RequestHeader
-import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)
-
-----------------------------------------------------------------
-
--- FIXME come up with good values here
-maxTotalHeaderLength :: Int
-maxTotalHeaderLength = 50 * 1024
+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)
 
 ----------------------------------------------------------------
 
@@ -68,7 +62,7 @@ recvRequest :: Bool -- ^ first request on this connection?
             -- Body producing action used for flushing the request body
 
 recvRequest firstRequest settings conn ii th addr src transport = do
-    hdrlines <- headerLines firstRequest src
+    hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src
     (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines
     let idxhdr = indexRequestHeader hdr
         expect = idxhdr ! fromEnum ReqExpect
@@ -107,16 +101,16 @@ recvRequest firstRequest settings conn ii th addr src transport = do
 
 ----------------------------------------------------------------
 
-headerLines :: Bool -> Source -> IO [ByteString]
-headerLines firstRequest src = do
+headerLines :: Int -> Bool -> Source -> IO [ByteString]
+headerLines maxTotalHeaderLength firstRequest src = do
     bs <- readSource src
     if S.null bs
         -- When we're working on a keep-alive connection and trying to
         -- get the second or later request, we don't want to treat the
         -- lack of data as a real exception. See the http1 function in
         -- the Run module for more details.
         then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest
-        else push src (THStatus 0 id id) bs
+        else push maxTotalHeaderLength src (THStatus 0 id id) bs
 
 data NoKeepAliveRequest = NoKeepAliveRequest
     deriving (Show, Typeable)
@@ -226,8 +220,8 @@ close :: Sink ByteString IO a
 close = throwIO IncompleteHeaders
 -}
 
-push :: Source -> THStatus -> ByteString -> IO [ByteString]
-push src (THStatus len lines prepend) bs'
+push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]
+push maxTotalHeaderLength src (THStatus len lines prepend) bs'
         -- Too many bytes
         | len > maxTotalHeaderLength = throwIO OverLargeHeader
         | otherwise = push' mnl
@@ -255,13 +249,13 @@ push src (THStatus len lines prepend) bs'
     push' Nothing = do
         bst <- readSource' src
         when (S.null bst) $ throwIO IncompleteHeaders
-        push src status bst
+        push maxTotalHeaderLength src status bst
       where
         len' = len + bsLen
         prepend' = S.append bs
         status = THStatus len' lines prepend'
     -- Found a newline, but next line continues as a multiline header
-    push' (Just (end, True)) = push src status rest
+    push' (Just (end, True)) = push maxTotalHeaderLength src status rest
       where
         rest = S.drop (end + 1) bs
         prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)
@@ -280,12 +274,12 @@ push src (THStatus len lines prepend) bs'
                       in if start < bsLen then
                              -- more bytes in this chunk, push again
                              let bs'' = SU.unsafeDrop start bs
-                              in push src status 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 src status bst
+                             push maxTotalHeaderLength src status bst
       where
         start = end + 1 -- start of next chunk
         line = SU.unsafeTake (checkCR bs end) bs

warp/Network/Wai/Handler/Warp/Settings.hs

@@ -128,6 +128,10 @@ data Settings = Settings
       -- Default: 2000.
       --
       -- Since 3.3.5
+    , settingsMaxTotalHeaderLength :: Int
+      -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.
+      -- 
+      -- Since 3.3.8
     }
 
 -- | Specify usage of the PROXY protocol.
@@ -166,6 +170,7 @@ defaultSettings = Settings
     , settingsGracefulShutdownTimeout = Nothing
     , settingsGracefulCloseTimeout1 = 0
     , settingsGracefulCloseTimeout2 = 2000
+    , settingsMaxTotalHeaderLength = 50 * 1024
     }
 
 -- | Apply the logic provided by 'defaultOnException' to determine if an

warp/test/RequestSpec.hs

@@ -7,6 +7,7 @@ module RequestSpec (main, spec) where
 import Network.Wai.Handler.Warp.File (parseByteRanges)
 import Network.Wai.Handler.Warp.Request
 import Network.Wai.Handler.Warp.Types
+import Network.Wai.Handler.Warp.Settings (settingsMaxTotalHeaderLength, defaultSettings)
 import Test.Hspec
 import Test.Hspec.QuickCheck
 import qualified Data.ByteString as S
@@ -17,6 +18,9 @@ import Data.IORef
 main :: IO ()
 main = hspec spec
 
+defaultMaxTotalHeaderLength :: Int
+defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings
+
 spec :: Spec
 spec = do
   describe "headerLines" $ do
@@ -63,29 +67,29 @@ spec = do
   describe "headerLines" $ do
       it "can handle a nomarl case" $ do
           src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource
-          x <- headerLines True src
+          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 True src
+          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 True src
+          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", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource
-          x <- headerLines True src
+          x <- headerLines defaultMaxTotalHeaderLength True src
           x `shouldBe` ["Status: 200", "Content-Type: text/plain"]
 
       it "can handle an illegal case (1)" $ do
           src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource
-          x <- headerLines True src
+          x <- headerLines defaultMaxTotalHeaderLength True src
           x `shouldBe` []
-          y <- headerLines True src
+          y <- headerLines defaultMaxTotalHeaderLength True src
           y `shouldBe` ["Status: 200", "Content-Type: text/plain"]
 
   where
@@ -111,7 +115,7 @@ headerLinesList' orig = do
                     writeIORef ref z
                     return y
     src' <- mkSource src
-    res <- headerLines True src'
+    res <- headerLines defaultMaxTotalHeaderLength True src'
     return (res, src')
 
 consumeLen :: Int -> Source -> IO S8.ByteString