adding yeild for schedule shaping.

yesodweb · Jul 22, 2013 · 4e9c631 · 4e9c631
1 parent 671720e
commit 4e9c631
Showing 1 changed file with 2 additions and 0 deletions.
diff --git a/warp/Network/Wai/Handler/Warp/Run.hs b/warp/Network/Wai/Handler/Warp/Run.hs
@@ -5,6 +5,7 @@ module Network.Wai.Handler.Warp.Run where
 
 import Control.Concurrent (threadDelay, forkIOWithUnmask)
 import Control.Exception
+import qualified Control.Concurrent as Conc (yield)
 import Control.Monad (forever, when, unless, void)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Trans.Class (lift)
@@ -255,6 +256,7 @@ serveConnection timeoutHandle settings cleaner port app conn remoteHost' =
                     liftIO $ T.resume th
                     sendResponse settings cleaner env conn res
 
+                liftIO $ Conc.yield
                 -- flush the rest of the request body
                 requestBody env $$ CL.sinkNull
                 ResumableSource fromClient' _ <- liftIO getSource