@@ -9,6 +9,7 @@ module Network.Wai.Handler.Warp.Request (
99 , headerLines
1010 , pauseTimeoutKey
1111 , getFileInfoKey
12+ , getClientCertificateKey
1213 , NoKeepAliveRequest (..)
1314 ) where
1415
@@ -21,6 +22,7 @@ import qualified Data.CaseInsensitive as CI
2122import qualified Data.IORef as I
2223import Data.Typeable (Typeable)
2324import qualified Data.Vault.Lazy as Vault
25+import Data.X509
2426import qualified Network.HTTP.Types as H
2527import Network.Socket (SockAddr)
2628import Network.Wai
@@ -36,13 +38,7 @@ import Network.Wai.Handler.Warp.Header
3638import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)
3739import Network.Wai.Handler.Warp.ReadInt
3840import Network.Wai.Handler.Warp.RequestHeader
39−import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)
40−
41−----------------------------------------------------------------
42−
43−-- FIXME come up with good values here
44−maxTotalHeaderLength :: Int
45−maxTotalHeaderLength = 50 * 1024
41+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)
4642
4743----------------------------------------------------------------
4844
@@ -66,7 +62,7 @@ recvRequest :: Bool -- ^ first request on this connection?
6662 -- Body producing action used for flushing the request body
6763
6864recvRequest firstRequest settings conn ii th addr src transport = do
69− hdrlines <- headerLines firstRequest src
65+ hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src
7066 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines
7167 let idxhdr = indexRequestHeader hdr
7268 expect = idxhdr ! fromEnum ReqExpect
@@ -76,6 +72,7 @@ recvRequest firstRequest settings conn ii th addr src transport = do
7672 rawPath = if settingsNoParsePath settings then unparsedPath else path
7773 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
7874 $ Vault.insert getFileInfoKey (getFileInfo ii)
75+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)
7976 Vault.empty
8077 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te
8178 -- body producing function which will produce '100-continue', if needed
@@ -104,8 +101,8 @@ recvRequest firstRequest settings conn ii th addr src transport = do
104101
105102----------------------------------------------------------------
106103
107−headerLines :: Bool -> Source -> IO [ByteString]
108−headerLines firstRequest src = do
104+headerLines :: Int -> Bool -> Source -> IO [ByteString]
105+headerLines maxTotalHeaderLength firstRequest src = do
109106 bs <- readSource src
110107 if S.null bs
111108 -- When we're working on a keep-alive connection and trying to
@@ -113,7 +110,7 @@ headerLines firstRequest src = do
113110 -- lack of data as a real exception. See the http1 function in
114111 -- the Run module for more details.
115112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest
116− else push src (THStatus 0 id id) bs
113+ else push maxTotalHeaderLength src (THStatus 0 id id) bs
117114
118115data NoKeepAliveRequest = NoKeepAliveRequest
119116 deriving (Show, Typeable)
@@ -223,8 +220,8 @@ close :: Sink ByteString IO a
223220close = throwIO IncompleteHeaders
224221-}
225222
226−push :: Source -> THStatus -> ByteString -> IO [ByteString]
227−push src (THStatus len lines prepend) bs'
223+push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]
224+push maxTotalHeaderLength src (THStatus len lines prepend) bs'
228225 -- Too many bytes
229226 | len > maxTotalHeaderLength = throwIO OverLargeHeader
230227 | otherwise = push' mnl
@@ -252,13 +249,13 @@ push src (THStatus len lines prepend) bs'
252249 push' Nothing = do
253250 bst <- readSource' src
254251 when (S.null bst) $ throwIO IncompleteHeaders
255− push src status bst
252+ push maxTotalHeaderLength src status bst
256253 where
257254 len' = len + bsLen
258255 prepend' = S.append bs
259256 status = THStatus len' lines prepend'
260257 -- Found a newline, but next line continues as a multiline header
261− push' (Just (end, True)) = push src status rest
258+ push' (Just (end, True)) = push maxTotalHeaderLength src status rest
262259 where
263260 rest = S.drop (end + 1) bs
264261 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)
@@ -277,12 +274,12 @@ push src (THStatus len lines prepend) bs'
277274 in if start < bsLen then
278275 -- more bytes in this chunk, push again
279276 let bs'' = SU.unsafeDrop start bs
280− in push src status bs''
277+ in push maxTotalHeaderLength src status bs''
281278 else do
282279 -- no more bytes in this chunk, ask for more
283280 bst <- readSource' src
284281 when (S.null bs) $ throwIO IncompleteHeaders
285− push src status bst
282+ push maxTotalHeaderLength src status bst
286283 where
287284 start = end + 1 -- start of next chunk
288285 line = SU.unsafeTake (checkCR bs end) bs
@@ -300,3 +297,7 @@ pauseTimeoutKey = unsafePerformIO Vault.newKey
300297getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)
301298getFileInfoKey = unsafePerformIO Vault.newKey
302299{-# NOINLINE getFileInfoKey #-}
300+
301+getClientCertificateKey :: Vault.Key (Maybe CertificateChain)
302+getClientCertificateKey = unsafePerformIO Vault.newKey
303+{-# NOINLINE getClientCertificateKey #-}