git.iko.soy/typeable/wai
on master help sign in
settingsPauseForApp
d2b6c66Michael Snoyman
warp/Network/Wai/Handler/Warp.hs+26−12
compare with master
unifiedsplit
@@ -34,6 +34,7 @@ module Network.Wai.Handler.Warp
34 , settingsHost
34 , settingsHost
35 , settingsOnException
35 , settingsOnException
36 , settingsTimeout
36 , settingsTimeout
37+ , settingsPauseForApp
37 -- * Datatypes
38 -- * Datatypes
38 , Port
39 , Port
39 , InvalidRequest (..)
40 , InvalidRequest (..)
@@ -101,7 +102,7 @@ import qualified Timeout as T
101import Timeout (Manager, registerKillThread, pause, resume)
102import Timeout (Manager, registerKillThread, pause, resume)
102import Data.Word (Word8)
103import Data.Word (Word8)
103import Data.List (foldl')
104import Data.List (foldl')
104−import Control.Monad (forever)
105+import Control.Monad (forever, when)
105import qualified Network.HTTP.Types as H
106import qualified Network.HTTP.Types as H
106import qualified Data.CaseInsensitive as CI
107import qualified Data.CaseInsensitive as CI
107import System.IO (hPutStrLn, stderr)
108import System.IO (hPutStrLn, stderr)
@@ -182,14 +183,15 @@ runSettingsSocket set socket app = do
182 (conn, sa) <- accept socket
183 (conn, sa) <- accept socket
183 _ <- forkIO $ do
184 _ <- forkIO $ do
184 th <- T.registerKillThread tm
185 th <- T.registerKillThread tm
185− serveConnection th onE port app conn sa
186+ serveConnection set th onE port app conn sa
186 T.cancel th
187 T.cancel th
187 return ()
188 return ()
188
189
189−serveConnection :: T.Handle
190+serveConnection :: Settings
191+ -> T.Handle
190 -> (SomeException -> IO ())
192 -> (SomeException -> IO ())
191 -> Port -> Application -> Socket -> SockAddr -> IO ()
193 -> Port -> Application -> Socket -> SockAddr -> IO ()
192−serveConnection th onException port app conn remoteHost' = do
194+serveConnection settings th onException port app conn remoteHost' = do
193 catch
195 catch
194 (finally
196 (finally
195 (E.run_ $ fromClient $$ serveConnection')
197 (E.run_ $ fromClient $$ serveConnection')
@@ -203,7 +205,7 @@ serveConnection th onException port app conn remoteHost' = do
203 liftIO $ T.pause th
205 liftIO $ T.pause th
204 res <- E.joinI $ EB.isolate len $$ app env
206 res <- E.joinI $ EB.isolate len $$ app env
205 liftIO $ T.resume th
207 liftIO $ T.resume th
206− keepAlive <- liftIO $ sendResponse th env conn res
208+ keepAlive <- liftIO $ sendResponse' settings th env conn res
207 if keepAlive then serveConnection' else return ()
209 if keepAlive then serveConnection' else return ()
208
210
209parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request)
211parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request)
@@ -342,9 +344,14 @@ hasBody :: H.Status -> Request -> Bool
342hasBody s req = s /= (H.Status 204 "") && s /= H.status304 &&
344hasBody s req = s /= (H.Status 204 "") && s /= H.status304 &&
343 H.statusCode s >= 200 && requestMethod req /= "HEAD"
345 H.statusCode s >= 200 && requestMethod req /= "HEAD"
344
346
347+-- Only present for backwards-compatibility
345sendResponse :: T.Handle
348sendResponse :: T.Handle
346 -> Request -> Socket -> Response -> IO Bool
349 -> Request -> Socket -> Response -> IO Bool
350+sendResponse = sendResponse' defaultSettings
351+
352+sendResponse' :: Settings -> T.Handle
353+ -> Request -> Socket -> Response -> IO Bool
347−sendResponse th req socket (ResponseFile s hs fp mpart) = do
354+sendResponse' _ th req socket (ResponseFile s hs fp mpart) = do
348 (hs', cl) <-
355 (hs', cl) <-
349 case (readInt `fmap` lookup "content-length" hs, mpart) of
356 case (readInt `fmap` lookup "content-length" hs, mpart) of
350 (Just cl, _) -> return (hs, cl)
357 (Just cl, _) -> return (hs, cl)
@@ -370,7 +377,7 @@ sendResponse th req socket (ResponseFile s hs fp mpart) = do
370 T.tickle th
377 T.tickle th
371 return isPersist
378 return isPersist
372 else return isPersist
379 else return isPersist
373−sendResponse th req socket (ResponseBuilder s hs b)
380+sendResponse' _ th req socket (ResponseBuilder s hs b)
374 | hasBody s req = do
381 | hasBody s req = do
375 toByteStringIO (\bs -> do
382 toByteStringIO (\bs -> do
376 Sock.sendAll socket bs
383 Sock.sendAll socket bs
@@ -394,7 +401,7 @@ sendResponse th req socket (ResponseBuilder s hs b)
394 isChunked' = isChunked (httpVersion req) && not hasLength
401 isChunked' = isChunked (httpVersion req) && not hasLength
395 isPersist = checkPersist req
402 isPersist = checkPersist req
396 isKeepAlive = isPersist && (isChunked' || hasLength)
403 isKeepAlive = isPersist && (isChunked' || hasLength)
397−sendResponse th req socket (ResponseEnumerator res) =
404+sendResponse' settings th req socket (ResponseEnumerator res) =
398 res go
405 res go
399 where
406 where
400 -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)
407 -- 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) =
406 go s hs = chunk'
413 go s hs = chunk'
407 $ E.enumList 1 [headers (httpVersion req) s hs isChunked']
414 $ E.enumList 1 [headers (httpVersion req) s hs isChunked']
408 $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString
415 $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString
409− $$ (iterSocket th socket >> return isKeepAlive)
416+ $$ (iterSocket pauseForApp th socket >> return isKeepAlive)
410 where
417 where
418+ pauseForApp = settingsPauseForApp settings
411 hasLength = lookup "content-length" hs /= Nothing
419 hasLength = lookup "content-length" hs /= Nothing
412 isChunked' = isChunked (httpVersion req) && not hasLength
420 isChunked' = isChunked (httpVersion req) && not hasLength
413 isPersist = checkPersist req
421 isPersist = checkPersist req
@@ -446,22 +454,26 @@ enumSocket th len socket =
446------ The functions below are not warp-specific and could be split out into a
454------ The functions below are not warp-specific and could be split out into a
447--separate package.
455--separate package.
448
456
457+iterSocket :: Bool -- ^ should this be paused? see 'settingsPauseForApp'
449−iterSocket :: T.Handle
458+ -> T.Handle
450 -> Socket
459 -> Socket
451 -> E.Iteratee B.ByteString IO ()
460 -> E.Iteratee B.ByteString IO ()
452−iterSocket th sock =
461+iterSocket pauseForApp th sock =
453 E.continue step
462 E.continue step
454 where
463 where
455 -- We pause timeouts before passing control back to user code. This ensures
464 -- We pause timeouts before passing control back to user code. This ensures
456 -- that a timeout will only ever be executed when Warp is in control. We
465 -- that a timeout will only ever be executed when Warp is in control. We
457 -- also make sure to resume the timeout after the completion of user code
466 -- also make sure to resume the timeout after the completion of user code
458 -- so that we can kill idle connections.
467 -- so that we can kill idle connections.
468+ --
469+ -- If settingsPauseForApp is 'True', then the timeout will
470+ -- not be paused during 'ResponseEnumerator' responses.
459 step E.EOF = liftIO (T.resume th) >> E.yield () E.EOF
471 step E.EOF = liftIO (T.resume th) >> E.yield () E.EOF
460 step (E.Chunks []) = E.continue step
472 step (E.Chunks []) = E.continue step
461 step (E.Chunks xs) = do
473 step (E.Chunks xs) = do
462 liftIO $ T.resume th
474 liftIO $ T.resume th
463 liftIO $ Sock.sendMany sock xs
475 liftIO $ Sock.sendMany sock xs
464− liftIO $ T.pause th
476+ when pauseForApp $ liftIO $ T.pause th
465 E.continue step
477 E.continue step
466
478
467-- | Various Warp server settings. This is purposely kept as an abstract data
479-- | Various Warp server settings. This is purposely kept as an abstract data
@@ -475,6 +487,7 @@ data Settings = Settings
475 , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
487 , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
476 , 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.
488 , 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.
477 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
489 , 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.
478 }
491 }
479
492
480-- | The default settings for the Warp server. See the individual settings for
493-- | The default settings for the Warp server. See the individual settings for
@@ -491,6 +504,7 @@ defaultSettings = Settings
491 then hPutStrLn stderr $ show e
504 then hPutStrLn stderr $ show e
492 else return ()
505 else return ()
493 , settingsTimeout = 30
506 , settingsTimeout = 30
507+ , settingsPauseForApp = True
494 }
508 }
495 where
509 where
496 go :: InvalidRequest -> IO ()
510 go :: InvalidRequest -> IO ()