git.iko.soy/typeable/wai
on master help sign in
refactoring Request.hs.
4189d02Kazu Yamamoto
warp/Network/Wai/Handler/Warp/Request.hs+98−72
compare with master
unifiedsplit
@@ -4,7 +4,7 @@
4
4
5module Network.Wai.Handler.Warp.Request (
5module Network.Wai.Handler.Warp.Request (
6 recvRequest
6 recvRequest
7− , takeHeaders
7+ , headerLines
8 ) where
8 ) where
9
9
10import Control.Applicative
10import Control.Applicative
@@ -28,64 +28,24 @@ import Network.Wai.Handler.Warp.Types
28import Prelude hiding (lines)
28import Prelude hiding (lines)
29import qualified Network.Wai.Handler.Warp.Timeout as Timeout
29import qualified Network.Wai.Handler.Warp.Timeout as Timeout
30
30
31+----------------------------------------------------------------
32+
31-- FIXME come up with good values here
33-- FIXME come up with good values here
32maxTotalHeaderLength :: Int
34maxTotalHeaderLength :: Int
33maxTotalHeaderLength = 50 * 1024
35maxTotalHeaderLength = 50 * 1024
34
36
37+----------------------------------------------------------------
38+
35recvRequest :: Connection
39recvRequest :: Connection
36 -> Timeout.Handle
40 -> Timeout.Handle
37 -> SockAddr
41 -> SockAddr
38 -> Source IO ByteString
42 -> Source IO ByteString
39 -> IO (Request, IO (ResumableSource IO ByteString))
43 -> IO (Request, IO (ResumableSource IO ByteString))
40−recvRequest conn timeoutHandle remoteHost' src1 = do
44+recvRequest conn timeoutHandle remoteHost' src0 = do
41− (src2, headers') <- src1 $$+ takeHeaders
45+ (src, hdrlines) <- src0 $$+ headerLines
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
46+ (method, rpath, gets, httpversion, hdr') <- parseHeaderLines hdrlines
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
47+ hdr <- liftIO $ handleExpect conn httpversion id hdr'
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) <-
48+ (rbody, bodyLength, getSource) <- bodyAndSource src hdr
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)
89
49
90 return (Request
50 return (Request
91 { requestMethod = method
51 { requestMethod = method
@@ -94,29 +54,32 @@ recvRequest' conn timeoutHandle (firstLine:otherLines) remoteHost' src = do
94 , rawPathInfo = rpath
54 , rawPathInfo = rpath
95 , rawQueryString = gets
55 , rawQueryString = gets
96 , queryString = H.parseQuery gets
56 , queryString = H.parseQuery gets
97− , requestHeaders = heads
57+ , requestHeaders = hdr
98 , isSecure = False
58 , isSecure = False
99 , remoteHost = remoteHost'
59 , remoteHost = remoteHost'
100− , requestBody = do
60+ , requestBody = timeoutBody timeoutHandle rbody
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
110 , vault = mempty
61 , vault = mempty
111−#if MIN_VERSION_wai(1, 4, 0)
112− , requestBodyLength =
62+ , requestBodyLength = bodyLength
113− if chunked
114− then ChunkedBody
115− else KnownLength $ fromIntegral len0
116−#endif
117 }, getSource)
63 }, getSource)
118
64
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+
120parseFirst :: ByteString
83parseFirst :: ByteString
121 -> IO (ByteString, ByteString, ByteString, H.HttpVersion)
84 -> IO (ByteString, ByteString, ByteString, H.HttpVersion)
122parseFirst s =
85parseFirst s =
@@ -134,12 +97,78 @@ parseFirst s =
134 else throwIO NonHttp
97 else throwIO NonHttp
135 _ -> throwIO $ BadFirstLine $ B.unpack s
98 _ -> throwIO $ BadFirstLine $ B.unpack s
136
99
100+----------------------------------------------------------------
101+
137parseHeaderNoAttr :: ByteString -> H.Header
102parseHeaderNoAttr :: ByteString -> H.Header
138parseHeaderNoAttr s =
103parseHeaderNoAttr s =
139 let (k, rest) = S.breakByte 58 s -- ':'
104 let (k, rest) = S.breakByte 58 s -- ':'
140 rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest
105 rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest
141 in (CI.mk k, rest')
106 in (CI.mk k, rest')
142
107
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+
143type BSEndo = ByteString -> ByteString
172type BSEndo = ByteString -> ByteString
144type BSEndoList = [ByteString] -> [ByteString]
173type BSEndoList = [ByteString] -> [ByteString]
145
174
@@ -148,10 +177,7 @@ data THStatus = THStatus
148 BSEndoList -- previously parsed lines
177 BSEndoList -- previously parsed lines
149 BSEndo -- bytestrings to be prepended
178 BSEndo -- bytestrings to be prepended
150
179
151−{-# INLINE takeHeaders #-}
180+----------------------------------------------------------------
152−takeHeaders :: Sink ByteString IO [ByteString]
153−takeHeaders =
154− await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))
155
181
156close :: Sink ByteString IO a
182close :: Sink ByteString IO a
157close = throwIO IncompleteHeaders
183close = throwIO IncompleteHeaders
warp/test/RequestSpec.hs+5−5
@@ -12,7 +12,7 @@ main :: IO ()
12main = hspec spec
12main = hspec spec
13
13
14spec :: Spec
14spec :: Spec
15−spec = describe "takeHeaders" $ do
15+spec = describe "headerLines" $ do
16 it "takes until blank" $
16 it "takes until blank" $
17 blankSafe >>= (`shouldBe` ["foo", "bar", "baz"])
17 blankSafe >>= (`shouldBe` ["foo", "bar", "baz"])
18 it "ignored leading whitespace in bodies" $
18 it "ignored leading whitespace in bodies" $
@@ -22,10 +22,10 @@ spec = describe "takeHeaders" $ do
22 it "throws OverLargeHeader when too large" $
22 it "throws OverLargeHeader when too large" $
23 tooLarge `shouldThrow` overLargeHeader
23 tooLarge `shouldThrow` overLargeHeader
24 where
24 where
25− blankSafe = (sourceList ["f", "oo\n", "bar\nbaz\n\r\n"]) $$ takeHeaders
25+ blankSafe = (sourceList ["f", "oo\n", "bar\nbaz\n\r\n"]) $$ headerLines
26− whiteSafe = (sourceList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]) $$ takeHeaders
26+ whiteSafe = (sourceList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]) $$ headerLines
27− tooMany = (sourceList $ repeat "f\n") $$ takeHeaders
27+ tooMany = (sourceList $ repeat "f\n") $$ headerLines
28− tooLarge = (sourceList $ repeat "f") $$ takeHeaders
28+ tooLarge = (sourceList $ repeat "f") $$ headerLines
29
29
30overLargeHeader :: Selector InvalidRequest
30overLargeHeader :: Selector InvalidRequest
31overLargeHeader e = e == OverLargeHeader
31overLargeHeader e = e == OverLargeHeader