@@ -20,6 +20,11 @@ module Network.Wai.Handler.Warp
2020 ( run
2121 , sendResponse
2222 , parseRequest
23+#if TEST
24+ , takeLineMax
25+ , takeUntilBlank
26+ , InvalidRequest (..)
27+#endif
2328 ) where
2429
2530import Prelude hiding (catch)
@@ -47,6 +52,7 @@ import Data.Typeable (Typeable)
4752import Data.Enumerator (($$), (>>==))
4853import qualified Data.Enumerator as E
4954import qualified Data.Enumerator.List as EL
55+import qualified Data.Enumerator.Binary as EB
5056import Blaze.ByteString.Builder.Enumerator (builderToByteString)
5157import Blaze.ByteString.Builder.HTTP
5258 (chunkedTransferEncoding, chunkedTransferTerminator)
@@ -55,6 +61,7 @@ import Blaze.ByteString.Builder
5561import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
5662import Data.Monoid (mconcat, mappend)
5763import Network.Socket.SendFile (sendFile)
64+import Network.Socket.Enumerator (iterSocket)
5865
5966import Control.Monad.IO.Class (liftIO)
6067import System.Timeout (timeout)
@@ -103,38 +110,6 @@ maxHeaderLength = 1024
103110bytesPerRead = 4096
104111readTimeout = 3000000
105112
106−takeUntilBlank :: Int
107− -> ([ByteString] -> [ByteString])
108− -> E.Iteratee S.ByteString IO [ByteString]
109−takeUntilBlank count _
110− | count > maxHeaders = E.throwError TooManyHeaders
111−takeUntilBlank count front = do
112− l <- takeLine 0 id
113− if B.null l
114− then return $ front []
115− else takeUntilBlank (count + 1) $ front . (:) l
116−
117−takeLine :: Int
118− -> ([ByteString] -> [ByteString])
119− -> E.Iteratee ByteString IO ByteString
120−takeLine len front = do
121− mbs <- EL.head
122− case mbs of
123− Nothing -> E.throwError IncompleteHeaders
124− Just bs -> do
125− let (x, y) = S.breakByte 10 bs
126− x' = if S.length x > 0 && S.last x == 13
127− then S.init x
128− else x
129− let len' = len + B.length x
130− case () of
131− ()
132− | len' > maxHeaderLength -> E.throwError OverLargeHeader
133− | B.null y -> takeLine len' $ front . (:) x
134− | otherwise -> do
135− E.yield () $ E.Chunks [B.drop 1 y]
136− return $ B.concat $ front [x']
137−
138113data InvalidRequest =
139114 NotEnoughLines [String]
140115 | BadFirstLine String
@@ -143,7 +118,7 @@ data InvalidRequest =
143118 | IncompleteHeaders
144119 | OverLargeHeader
145120 | SocketTimeout
146− deriving (Show, Typeable)
121+ deriving (Show, Typeable, Eq)
147122instance Exception InvalidRequest
148123
149124-- | Parse a set of header lines and body into a 'Request'.
@@ -170,7 +145,9 @@ parseRequest' port (firstLine:otherLines) remoteHost' = do
170145 (x, _):_ -> x
171146 [] -> 0
172147 let serverName' = takeUntil 58 host -- ':'
173− return (requestBodyHandle len, Request
148+ -- FIXME isolate takes an Integer instead of Int or Int64. If this is a
149+ -- performance penalty, we may need our own version.
150+ return (EB.isolate len, Request
174151 { requestMethod = method
175152 , httpVersion = httpversion
176153 , pathInfo = rpath
@@ -297,45 +274,8 @@ parseHeaderNoAttr s =
297274 else rest
298275 in (mkCIByteString k, rest')
299276
300−requestBodyHandle :: Int
301− -> E.Enumeratee ByteString ByteString IO a
302−requestBodyHandle initLen =
303− go initLen
304− where
305− go 0 step = return step
306− go len (E.Continue k) = do
307− x <- E.head
308− case x of
309− Nothing -> return $ E.Continue k
310− Just bs -> do
311− (bs', newlen) <- yieldExtra len bs
312− k (E.Chunks [bs']) >>== go newlen
313− go len step = do
314− drain len
315− return step
316− drain 0 = return ()
317− drain len = do
318− mbs <- E.head
319− case mbs of
320− Nothing -> return ()
321− Just bs -> do
322− (_, newlen) <- yieldExtra len bs
323− drain newlen
324− yieldExtra len bs
325− | B.length bs == len = return (bs, 0)
326− | B.length bs < len = return (bs, len - B.length bs)
327− | otherwise = do
328− let (x, y) = B.splitAt len bs
329− E.yield () $ E.Chunks [y]
330− return (x, 0)
331−
332−iterSocket :: Socket -> E.Iteratee ByteString IO ()
333−iterSocket socket =
334− E.continue go
335− where
336− go E.EOF = E.yield () E.EOF
337− go (E.Chunks cs) = liftIO (Sock.sendMany socket cs) >> E.continue go
338−
277+-- FIXME when we switch to Jeremy's timeout code, we can probably start using
278+-- network-enumerator's enumSocket
339279enumSocket :: Int -> Socket -> E.Enumerator ByteString IO a
340280enumSocket len socket (E.Continue k) = do
341281#if NO_TIMEOUT_PROTECTION
@@ -352,3 +292,38 @@ enumSocket len socket (E.Continue k) = do
352292 | S.length bs == 0 = E.continue k
353293 | otherwise = k (E.Chunks [bs]) >>== enumSocket len socket
354294enumSocket _ _ step = E.returnI step
295+
296+------ The functions below are not warp-specific and could be split out into a
297+--separate package.
298+
299+takeUntilBlank :: Int
300+ -> ([ByteString] -> [ByteString])
301+ -> E.Iteratee S.ByteString IO [ByteString]
302+takeUntilBlank count _
303+ | count > maxHeaders = E.throwError TooManyHeaders
304+takeUntilBlank count front = do
305+ l <- takeLineMax 0 id
306+ if B.null l
307+ then return $ front []
308+ else takeUntilBlank (count + 1) $ front . (:) l
309+
310+takeLineMax :: Int
311+ -> ([ByteString] -> [ByteString])
312+ -> E.Iteratee ByteString IO ByteString
313+takeLineMax len front = do
314+ mbs <- EL.head
315+ case mbs of
316+ Nothing -> E.throwError IncompleteHeaders
317+ Just bs -> do
318+ let (x, y) = S.breakByte 10 bs
319+ x' = if S.length x > 0 && S.last x == 13
320+ then S.init x
321+ else x
322+ let len' = len + B.length x
323+ case () of
324+ ()
325+ | len' > maxHeaderLength -> E.throwError OverLargeHeader
326+ | B.null y -> takeLineMax len' $ front . (:) x
327+ | otherwise -> do
328+ E.yield () $ E.Chunks [B.drop 1 y]
329+ return $ B.concat $ front [x']