@@ -34,6 +34,7 @@ module Network.Wai.Handler.Warp
3434 , settingsHost
3535 , settingsOnException
3636 , settingsTimeout
37+ , settingsPauseForApp
3738 -- * Datatypes
3839 , Port
3940 , InvalidRequest (..)
@@ -101,7 +102,7 @@ import qualified Timeout as T
101102import Timeout (Manager, registerKillThread, pause, resume)
102103import Data.Word (Word8)
103104import Data.List (foldl')
104−import Control.Monad (forever)
105+import Control.Monad (forever, when)
105106import qualified Network.HTTP.Types as H
106107import qualified Data.CaseInsensitive as CI
107108import System.IO (hPutStrLn, stderr)
@@ -182,14 +183,15 @@ runSettingsSocket set socket app = do
182183 (conn, sa) <- accept socket
183184 _ <- forkIO $ do
184185 th <- T.registerKillThread tm
185− serveConnection th onE port app conn sa
186+ serveConnection set th onE port app conn sa
186187 T.cancel th
187188 return ()
188189
189−serveConnection :: T.Handle
190+serveConnection :: Settings
191+ -> T.Handle
190192 -> (SomeException -> IO ())
191193 -> Port -> Application -> Socket -> SockAddr -> IO ()
192−serveConnection th onException port app conn remoteHost' = do
194+serveConnection settings th onException port app conn remoteHost' = do
193195 catch
194196 (finally
195197 (E.run_ $ fromClient $$ serveConnection')
@@ -203,7 +205,7 @@ serveConnection th onException port app conn remoteHost' = do
203205 liftIO $ T.pause th
204206 res <- E.joinI $ EB.isolate len $$ app env
205207 liftIO $ T.resume th
206− keepAlive <- liftIO $ sendResponse th env conn res
208+ keepAlive <- liftIO $ sendResponse' settings th env conn res
207209 if keepAlive then serveConnection' else return ()
208210
209211parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request)
@@ -342,9 +344,14 @@ hasBody :: H.Status -> Request -> Bool
342344hasBody s req = s /= (H.Status 204 "") && s /= H.status304 &&
343345 H.statusCode s >= 200 && requestMethod req /= "HEAD"
344346
347+-- Only present for backwards-compatibility
345348sendResponse :: T.Handle
346349 -> Request -> Socket -> Response -> IO Bool
347−sendResponse th req socket (ResponseFile s hs fp mpart) = do
350+sendResponse = sendResponse' defaultSettings
351+
352+sendResponse' :: Settings -> T.Handle
353+ -> Request -> Socket -> Response -> IO Bool
354+sendResponse' _ th req socket (ResponseFile s hs fp mpart) = do
348355 (hs', cl) <-
349356 case (readInt `fmap` lookup "content-length" hs, mpart) of
350357 (Just cl, _) -> return (hs, cl)
@@ -370,7 +377,7 @@ sendResponse th req socket (ResponseFile s hs fp mpart) = do
370377 T.tickle th
371378 return isPersist
372379 else return isPersist
373−sendResponse th req socket (ResponseBuilder s hs b)
380+sendResponse' _ th req socket (ResponseBuilder s hs b)
374381 | hasBody s req = do
375382 toByteStringIO (\bs -> do
376383 Sock.sendAll socket bs
@@ -394,7 +401,7 @@ sendResponse th req socket (ResponseBuilder s hs b)
394401 isChunked' = isChunked (httpVersion req) && not hasLength
395402 isPersist = checkPersist req
396403 isKeepAlive = isPersist && (isChunked' || hasLength)
397−sendResponse th req socket (ResponseEnumerator res) =
404+sendResponse' settings th req socket (ResponseEnumerator res) =
398405 res go
399406 where
400407 -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)
@@ -406,8 +413,9 @@ sendResponse th req socket (ResponseEnumerator res) =
406413 go s hs = chunk'
407414 $ E.enumList 1 [headers (httpVersion req) s hs isChunked']
408415 $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString
409− $$ (iterSocket th socket >> return isKeepAlive)
416+ $$ (iterSocket pauseForApp th socket >> return isKeepAlive)
410417 where
418+ pauseForApp = settingsPauseForApp settings
411419 hasLength = lookup "content-length" hs /= Nothing
412420 isChunked' = isChunked (httpVersion req) && not hasLength
413421 isPersist = checkPersist req
@@ -446,22 +454,26 @@ enumSocket th len socket =
446454------ The functions below are not warp-specific and could be split out into a
447455--separate package.
448456
449−iterSocket :: T.Handle
457+iterSocket :: Bool -- ^ should this be paused? see 'settingsPauseForApp'
458+ -> T.Handle
450459 -> Socket
451460 -> E.Iteratee B.ByteString IO ()
452−iterSocket th sock =
461+iterSocket pauseForApp th sock =
453462 E.continue step
454463 where
455464 -- We pause timeouts before passing control back to user code. This ensures
456465 -- that a timeout will only ever be executed when Warp is in control. We
457466 -- also make sure to resume the timeout after the completion of user code
458467 -- so that we can kill idle connections.
468+ --
469+ -- If settingsPauseForApp is 'True', then the timeout will
470+ -- not be paused during 'ResponseEnumerator' responses.
459471 step E.EOF = liftIO (T.resume th) >> E.yield () E.EOF
460472 step (E.Chunks []) = E.continue step
461473 step (E.Chunks xs) = do
462474 liftIO $ T.resume th
463475 liftIO $ Sock.sendMany sock xs
464− liftIO $ T.pause th
476+ when pauseForApp $ liftIO $ T.pause th
465477 E.continue step
466478
467479-- | Various Warp server settings. This is purposely kept as an abstract data
@@ -475,6 +487,7 @@ data Settings = Settings
475487 , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
476488 , settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.
477489 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
490+ , settingsPauseForApp :: Bool -- ^ If 'True', timeout will be paused while executing the application, 'False' otherwise. Default is 'True'. 'False' is useful for cases such as an untrusted CGI application. Note that this /only/ affects execution of 'ResponseEnumerator' responses.
478491 }
479492
480493-- | The default settings for the Warp server. See the individual settings for
@@ -491,6 +504,7 @@ defaultSettings = Settings
491504 then hPutStrLn stderr $ show e
492505 else return ()
493506 , settingsTimeout = 30
507+ , settingsPauseForApp = True
494508 }
495509 where
496510 go :: InvalidRequest -> IO ()