@@ -48,14 +48,12 @@ import qualified Data.ByteString as S
4848import qualified Data.ByteString.Unsafe as SU
4949import qualified Data.ByteString.Char8 as B
5050import qualified Data.ByteString.Lazy as L
51−import Network
52− ( listenOn, sClose, PortID(PortNumber), Socket
53− , withSocketsDo)
51+import Network (listenOn, sClose, PortID(PortNumber), Socket)
5452import Network.Socket
5553 ( accept, SockAddr
5654 )
5755import qualified Network.Socket.ByteString as Sock
58−import Control.Exception (bracket, finally, Exception, SomeException, catch, throwIO)
56+import Control.Exception (bracket, finally, Exception, SomeException, catch)
5957import Control.Concurrent (forkIO)
6058import Data.Maybe (fromMaybe)
6159
@@ -73,17 +71,17 @@ import Blaze.ByteString.Builder
7371import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
7472import Data.Monoid (mappend, mconcat)
7573import Network.Socket.SendFile (sendFile)
76−import Network.Socket.Enumerator (iterSocket)
7774
7875import Control.Monad.IO.Class (liftIO)
79−import System.Timeout (timeout)
76+import qualified Timeout as T
8077import Data.Word (Word8)
8178import Data.List (foldl')
79+import Control.Monad (forever)
8280
8381#if WINDOWS
8482import Control.Concurrent (threadDelay)
8583import qualified Control.Concurrent.MVar as MV
86−import Control.Monad (forever)
84+import Network.Socket (withSocketsDo)
8785#endif
8886
8987-- | Run an 'Application' on the given port, ignoring all exceptions.
@@ -105,7 +103,7 @@ runEx onE port app = withSocketsDo $ do
105103 serveConnections onE port app s)
106104 forever (threadDelay maxBound) `finally` clean
107105#else
108−runEx onE port = withSocketsDo . -- FIXME should this be called by client user instead?
106+runEx onE port =
109107 bracket
110108 (listenOn $ PortNumber $ fromIntegral port)
111109 sClose .
@@ -122,24 +120,32 @@ type Port = Int
122120serveConnections :: (SomeException -> IO ())
123121 -> Port -> Application -> Socket -> IO ()
124122serveConnections onE port app socket = do
125− (conn, sa) <- accept socket
126− _ <- forkIO $ serveConnection onE port app conn sa
127− serveConnections onE port app socket
128−
129−serveConnection :: (SomeException -> IO ())
123+ tm <- T.initialize $ timeout * 1000000
124+ forever $ do
125+ (conn, sa) <- accept socket
126+ _ <- forkIO $ do
127+ th <- T.register tm $ sClose conn
128+ serveConnection th onE port app conn sa
129+ return ()
130+
131+serveConnection :: T.Handle
132+ -> (SomeException -> IO ())
130133 -> Port -> Application -> Socket -> SockAddr -> IO ()
131−serveConnection onException port app conn remoteHost' = do
134+serveConnection th onException port app conn remoteHost' = do
132135 catch
133136 (finally
134137 (E.run_ $ fromClient $$ serveConnection')
135138 (sClose conn))
136139 onException
137140 where
138− fromClient = enumSocket bytesPerRead conn
141+ fromClient = enumSocket th bytesPerRead conn
139142 serveConnection' = do
140143 (enumeratee, env) <- parseRequest port remoteHost'
144+ -- Let the application run for as long as it wants
145+ --FIXME liftIO $ T.pause th
141146 res <- E.joinI $ enumeratee $$ app env
142− keepAlive <- liftIO $ sendResponse env (httpVersion env) conn res
147+ --liftIO $ T.resume th
148+ keepAlive <- liftIO $ sendResponse th env (httpVersion env) conn res
143149 if keepAlive then serveConnection' else return ()
144150
145151parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (E.Enumeratee ByteString ByteString IO a, Request)
@@ -148,11 +154,11 @@ parseRequest port remoteHost' = do
148154 parseRequest' port headers' remoteHost'
149155
150156-- FIXME come up with good values here
151−maxHeaders, maxHeaderLength, bytesPerRead, readTimeout :: Int
157+maxHeaders, maxHeaderLength, bytesPerRead, timeout :: Int
152158maxHeaders = 30
153159maxHeaderLength = 1024
154160bytesPerRead = 4096
155−readTimeout = 3000000
161+timeout = 1 -- seconds
156162
157163data InvalidRequest =
158164 NotEnoughLines [String]
@@ -170,7 +176,7 @@ parseRequest' :: Port
170176 -> [ByteString]
171177 -> SockAddr
172178 -> E.Iteratee S.ByteString IO (E.Enumeratee S.ByteString S.ByteString IO a, Request)
173−parseRequest' _ [] _ = throwError $ NotEnoughLines []
179+parseRequest' _ [] _ = E.throwError $ NotEnoughLines []
174180parseRequest' port (firstLine:otherLines) remoteHost' = do
175181 (method, rpath', gets, httpversion) <- parseFirst firstLine
176182 let rpath =
@@ -217,13 +223,13 @@ parseFirst s = do
217223 (method, query, http') <-
218224 case pieces of
219225 [x, y, z] -> return (x, y, z)
220− _ -> throwError $ BadFirstLine $ B.unpack s
226+ _ -> E.throwError $ BadFirstLine $ B.unpack s
221227 let (hfirst, hsecond) = B.splitAt 5 http'
222228 if (hfirst == "HTTP/")
223229 then
224230 let (rpath, qstring) = B.break (== '?') query
225231 in return (method, rpath, qstring, hsecond)
226− else throwError NonHttp
232+ else E.throwError NonHttp
227233{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported
228234
229235httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder
@@ -262,15 +268,16 @@ isChunked = (==) http11
262268hasBody :: Status -> Request -> Bool
263269hasBody s req = s /= (Status 204 "") && requestMethod req /= "HEAD"
264270
265−sendResponse :: Request -> HttpVersion -> Socket -> Response -> IO Bool
266−sendResponse req hv socket (ResponseFile s hs fp) = do
271+sendResponse :: T.Handle
272+ -> Request -> HttpVersion -> Socket -> Response -> IO Bool
273+sendResponse _FIXMEth req hv socket (ResponseFile s hs fp) = do
267274 Sock.sendMany socket $ L.toChunks $ toLazyByteString $ headers hv s hs False
268275 if hasBody s req
269276 then do
270− sendFile socket fp
277+ sendFile socket fp -- FIXME tickle the timeout here
271278 return $ lookup "content-length" hs /= Nothing
272279 else return True
273−sendResponse req hv socket (ResponseBuilder s hs b)
280+sendResponse _FIXMEth req hv socket (ResponseBuilder s hs b)
274281 | hasBody s req = do
275282 toByteStringIO (Sock.sendAll socket) b'
276283 return isKeepAlive
@@ -291,7 +298,7 @@ sendResponse req hv socket (ResponseBuilder s hs b)
291298 hasLength = lookup "content-length" hs /= Nothing
292299 isChunked' = isChunked hv && not hasLength
293300 isKeepAlive = isChunked' || hasLength
294−sendResponse req hv socket (ResponseEnumerator res) =
301+sendResponse th req hv socket (ResponseEnumerator res) =
295302 res go
296303 where
297304 -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)
@@ -305,7 +312,7 @@ sendResponse req hv socket (ResponseEnumerator res) =
305312 chunk'
306313 $ E.enumList 1 [headers hv s hs isChunked']
307314 $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString
308− $$ (iterSocket socket >> return isKeepAlive)
315+ $$ (iterSocket th socket >> return isKeepAlive)
309316 where
310317 hasLength = lookup "content-length" hs /= Nothing
311318 isChunked' = isChunked hv && not hasLength
@@ -331,24 +338,20 @@ parseHeaderNoAttr s =
331338 else rest
332339 in (mkCIByteString k, rest')
333340
334−-- FIXME when we switch to Jeremy's timeout code, we can probably start using
335−-- network-enumerator's enumSocket
336−enumSocket :: Int -> Socket -> E.Enumerator ByteString IO a
337−enumSocket len socket (E.Continue k) = do
338−#if NO_TIMEOUT_PROTECTION
339− bs <- liftIO $ Sock.recv socket len
340− go bs
341−#else
342− mbs <- liftIO $ timeout readTimeout $ Sock.recv socket len
343− case mbs of
344− Nothing -> throwError SocketTimeout
345− Just bs -> go bs
346−#endif
341+enumSocket :: T.Handle -> Int -> Socket -> E.Enumerator ByteString IO a
342+enumSocket th len socket =
343+ inner
347344 where
348− go bs
345+ inner (E.Continue k) = do
346+ bs <- liftIO $ Sock.recv socket len
347+ liftIO $ T.tickle th
348+ if S.null bs
349+ then E.throwError SocketTimeout
350+ else go k bs
351+ inner step = E.returnI step
352+ go k bs
349353 | S.length bs == 0 = E.continue k
350− | otherwise = k (E.Chunks [bs]) >>== enumSocket len socket
351−enumSocket _ _ step = E.returnI step
354+ | otherwise = k (E.Chunks [bs]) >>== enumSocket th len socket
352355
353356------ The functions below are not warp-specific and could be split out into a
354357--separate package.
@@ -360,7 +363,7 @@ takeUntilBlank :: Int
360363 -> ([ByteString] -> [ByteString])
361364 -> E.Iteratee S.ByteString IO [ByteString]
362365takeUntilBlank count _
363− | count > maxHeaders = throwError TooManyHeaders
366+ | count > maxHeaders = E.throwError TooManyHeaders
364367takeUntilBlank count front = do
365368 l <- takeLineMax 0 id
366369 if B.null l
@@ -373,7 +376,7 @@ takeLineMax :: Int
373376takeLineMax len front = do
374377 mbs <- EL.head
375378 case mbs of
376− Nothing -> throwError IncompleteHeaders
379+ Nothing -> E.throwError IncompleteHeaders
377380 Just bs -> do
378381 let (x, y) = S.breakByte 10 bs
379382 x' = if S.length x > 0 && S.last x == 13
@@ -382,10 +385,21 @@ takeLineMax len front = do
382385 let len' = len + B.length x
383386 case () of
384387 ()
385− | len' > maxHeaderLength -> throwError OverLargeHeader
388+ | len' > maxHeaderLength -> E.throwError OverLargeHeader
386389 | B.null y -> takeLineMax len' $ front . (:) x
387390 | otherwise -> do
388391 E.yield () $ E.Chunks [B.drop 1 y]
389392 return $ B.concat $ front [x']
390393
391−throwError = liftIO . throwIO
394+iterSocket :: T.Handle
395+ -> Socket
396+ -> E.Iteratee B.ByteString IO ()
397+iterSocket th sock =
398+ E.continue step
399+ where
400+ step E.EOF = E.yield () E.EOF
401+ step (E.Chunks []) = E.continue step
402+ step (E.Chunks xs) = do
403+ liftIO $ Sock.sendMany sock xs
404+ liftIO $ T.tickle th
405+ E.continue step