@@ -4,7 +4,7 @@
44
55module Network.Wai.Handler.Warp.Request (
66 recvRequest
7− , takeHeaders
7+ , headerLines
88 ) where
99
1010import Control.Applicative
@@ -28,64 +28,24 @@ import Network.Wai.Handler.Warp.Types
2828import Prelude hiding (lines)
2929import qualified Network.Wai.Handler.Warp.Timeout as Timeout
3030
31+----------------------------------------------------------------
32+
3133-- FIXME come up with good values here
3234maxTotalHeaderLength :: Int
3335maxTotalHeaderLength = 50 * 1024
3436
37+----------------------------------------------------------------
38+
3539recvRequest :: Connection
3640 -> Timeout.Handle
3741 -> SockAddr
3842 -> Source IO ByteString
3943 -> IO (Request, IO (ResumableSource IO ByteString))
40−recvRequest conn timeoutHandle remoteHost' src1 = do
41− (src2, headers') <- src1 $$+ takeHeaders
42− recvRequest' conn timeoutHandle headers' remoteHost' src2
43−
44−handleExpect :: Connection
45− -> H.HttpVersion
46− -> ([H.Header] -> [H.Header])
47− -> [H.Header]
48− -> IO [H.Header]
49−handleExpect _ _ front [] = return $ front []
50−handleExpect conn hv front (("expect", "100-continue"):rest) = do
51− connSendAll conn $
52− if hv == H.http11
53− then "HTTP/1.1 100 Continue\r\n\r\n"
54− else "HTTP/1.0 100 Continue\r\n\r\n"
55− return $ front rest
56−handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs
57−
58−-- | Parse a set of header lines and body into a 'Request'.
59−recvRequest' :: Connection
60− -> Timeout.Handle
61− -> [ByteString]
62− -> SockAddr
63− -> ResumableSource IO ByteString -- FIXME was buffered
64− -> IO (Request, IO (ResumableSource IO ByteString))
65−recvRequest' _ _ [] _ _ = throwIO $ NotEnoughLines []
66−recvRequest' conn timeoutHandle (firstLine:otherLines) remoteHost' src = do
67− (method, rpath', gets, httpversion) <- parseFirst firstLine
68− let rpath
69− | S.null rpath' = "/"
70− | "http://" `S.isPrefixOf` rpath' = snd $ S.breakByte 47 $ S.drop 7 rpath'
71− | otherwise = rpath'
72− heads <- liftIO
73− $ handleExpect conn httpversion id
74− (map parseHeaderNoAttr otherLines)
75− let len0 =
76− case lookup H.hContentLength heads of
77− Nothing -> 0
78− Just bs -> readInt bs
79− let chunked = maybe False ((== "chunked") . CI.foldCase)
80− $ lookup hTransferEncoding heads
81− (rbody, getSource) <-
82− if chunked
83− then do
84− ref <- I.newIORef (src, NeedLen)
85− return (chunkedSource ref, fst <$> I.readIORef ref)
86− else do
87− ibs <- IsolatedBSSource <$> I.newIORef (len0, src)
88− return (ibsIsolate ibs, ibsDone ibs)
44+recvRequest conn timeoutHandle remoteHost' src0 = do
45+ (src, hdrlines) <- src0 $$+ headerLines
46+ (method, rpath, gets, httpversion, hdr') <- parseHeaderLines hdrlines
47+ hdr <- liftIO $ handleExpect conn httpversion id hdr'
48+ (rbody, bodyLength, getSource) <- bodyAndSource src hdr
8949
9050 return (Request
9151 { requestMethod = method
@@ -94,29 +54,32 @@ recvRequest' conn timeoutHandle (firstLine:otherLines) remoteHost' src = do
9454 , rawPathInfo = rpath
9555 , rawQueryString = gets
9656 , queryString = H.parseQuery gets
97− , requestHeaders = heads
57+ , requestHeaders = hdr
9858 , isSecure = False
9959 , remoteHost = remoteHost'
100− , requestBody = do
101− -- Timeout handling was paused after receiving the full request
102− -- headers. Now we need to resume it to avoid a slowloris
103− -- attack during request body sending.
104− liftIO $ Timeout.resume timeoutHandle
105− -- As soon as we finish receiving the request body, whether
106− -- because the application is not interested in more bytes, or
107− -- because there is no more data available, pause the timeout
108− -- handler again.
109− addCleanup (const $ liftIO $ Timeout.pause timeoutHandle) rbody
60+ , requestBody = timeoutBody timeoutHandle rbody
11061 , vault = mempty
111−#if MIN_VERSION_wai(1, 4, 0)
112− , requestBodyLength =
113− if chunked
114− then ChunkedBody
115− else KnownLength $ fromIntegral len0
116−#endif
62+ , requestBodyLength = bodyLength
11763 }, getSource)
11864
119−{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported
65+----------------------------------------------------------------
66+
67+headerLines :: Sink ByteString IO [ByteString]
68+headerLines =
69+ await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))
70+
71+----------------------------------------------------------------
72+
73+parseHeaderLines :: [ByteString] -> IO (ByteString, ByteString, ByteString, H.HttpVersion, [H.Header])
74+parseHeaderLines [] = throwIO $ NotEnoughLines []
75+parseHeaderLines (firstLine:otherLines) = do
76+ (method, rpath', gets, httpversion) <- parseFirst firstLine
77+ let rpath = parseRpath rpath'
78+ hdr = map parseHeaderNoAttr otherLines
79+ return (method, rpath, gets, httpversion, hdr)
80+
81+----------------------------------------------------------------
82+
12083parseFirst :: ByteString
12184 -> IO (ByteString, ByteString, ByteString, H.HttpVersion)
12285parseFirst s =
@@ -134,12 +97,78 @@ parseFirst s =
13497 else throwIO NonHttp
13598 _ -> throwIO $ BadFirstLine $ B.unpack s
13699
100+----------------------------------------------------------------
101+
137102parseHeaderNoAttr :: ByteString -> H.Header
138103parseHeaderNoAttr s =
139104 let (k, rest) = S.breakByte 58 s -- ':'
140105 rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest
141106 in (CI.mk k, rest')
142107
108+----------------------------------------------------------------
109+
110+parseRpath :: ByteString -> ByteString
111+parseRpath rpath'
112+ | S.null rpath' = "/"
113+ | "http://" `S.isPrefixOf` rpath' = snd $ S.breakByte 47 $ S.drop 7 rpath'
114+ | otherwise = rpath'
115+
116+----------------------------------------------------------------
117+
118+handleExpect :: Connection
119+ -> H.HttpVersion
120+ -> ([H.Header] -> [H.Header])
121+ -> [H.Header]
122+ -> IO [H.Header]
123+handleExpect _ _ front [] = return $ front []
124+handleExpect conn hv front (("expect", "100-continue"):rest) = do
125+ connSendAll conn $
126+ if hv == H.http11
127+ then "HTTP/1.1 100 Continue\r\n\r\n"
128+ else "HTTP/1.0 100 Continue\r\n\r\n"
129+ return $ front rest
130+handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs
131+
132+----------------------------------------------------------------
133+
134+bodyAndSource :: ResumableSource IO ByteString
135+ -> [H.Header]
136+ -> IO (Source IO ByteString
137+ ,RequestBodyLength
138+ ,IO (ResumableSource IO ByteString))
139+bodyAndSource src hdr
140+ | chunked = do
141+ ref <- I.newIORef (src, NeedLen)
142+ return (chunkedSource ref, ChunkedBody, fst <$> I.readIORef ref)
143+ | otherwise = do
144+ ibs <- IsolatedBSSource <$> I.newIORef (len0, src)
145+ return (ibsIsolate ibs, bodyLen, ibsDone ibs)
146+ where
147+ len0 = case lookup H.hContentLength hdr of
148+ Nothing -> 0
149+ Just bs -> readInt bs
150+ bodyLen = KnownLength $ fromIntegral len0
151+ chunked = isChunked hdr
152+
153+isChunked :: [H.Header] -> Bool
154+isChunked hdr = maybe False ((== "chunked") . CI.foldCase) $ lookup hTransferEncoding hdr
155+
156+----------------------------------------------------------------
157+
158+timeoutBody :: Timeout.Handle -> Source IO ByteString -> Source IO ByteString
159+timeoutBody timeoutHandle rbody = do
160+ -- Timeout handling was paused after receiving the full request
161+ -- headers. Now we need to resume it to avoid a slowloris
162+ -- attack during request body sending.
163+ liftIO $ Timeout.resume timeoutHandle
164+ -- As soon as we finish receiving the request body, whether
165+ -- because the application is not interested in more bytes, or
166+ -- because there is no more data available, pause the timeout
167+ -- handler again.
168+ addCleanup (const $ liftIO $ Timeout.pause timeoutHandle) rbody
169+
170+----------------------------------------------------------------
171+
143172type BSEndo = ByteString -> ByteString
144173type BSEndoList = [ByteString] -> [ByteString]
145174
@@ -148,10 +177,7 @@ data THStatus = THStatus
148177 BSEndoList -- previously parsed lines
149178 BSEndo -- bytestrings to be prepended
150179
151−{-# INLINE takeHeaders #-}
152−takeHeaders :: Sink ByteString IO [ByteString]
153−takeHeaders =
154− await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))
180+----------------------------------------------------------------
155181
156182close :: Sink ByteString IO a
157183close = throwIO IncompleteHeaders