@@ -27,6 +27,7 @@ import Network.Wai.Handler.Warp.Response
2727import Network.Wai.Handler.Warp.Settings
2828import qualified Network.Wai.Handler.Warp.Timeout as T
2929import Network.Wai.Handler.Warp.Types
30+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
3031
3132-- Sock.recv first tries to call recvfrom() optimistically.
3233-- If EAGAIN returns, it polls incoming data with epoll/kqueue.
@@ -234,19 +235,20 @@ serveConnection :: T.Handle
234235 -> Settings
235236 -> Cleaner
236237 -> Port -> Application -> Connection -> SockAddr-> IO ()
237−serveConnection timeoutHandle settings cleaner port app conn remoteHost' =
238− respondOnException settings cleaner conn remoteHost' $
239− runResourceT serveConnection'
238+serveConnection timeoutHandle settings cleaner port app conn remoteHost' = do
239+ istatus <- newIORef False
240+ respondOnException istatus settings cleaner conn remoteHost' $
241+ runResourceT (serveConnection' istatus)
240242 where
241243 innerRunResourceT
242244 | settingsResourceTPerRequest settings = lift . runResourceT
243245 | otherwise = id
244246 th = threadHandle cleaner
245247
246− serveConnection' :: ResourceT IO ()
247− serveConnection' = serveConnection'' $ connSource conn th
248+ serveConnection' :: IORef Bool -> ResourceT IO ()
249+ serveConnection' istatus = serveConnection'' istatus $ connSource istatus conn th
248250
249− serveConnection'' fromClient = do
251+ serveConnection'' istatus fromClient = do
250252 (env, getSource) <- parseRequestInternal conn timeoutHandle port remoteHost' fromClient
251253 case settingsIntercept settings env of
252254 Nothing -> do
@@ -256,33 +258,39 @@ serveConnection timeoutHandle settings cleaner port app conn remoteHost' =
256258 res <- app env
257259
258260 liftIO $ T.resume th
261+ writeIORef istatus False
259262 sendResponse settings cleaner env conn res
260263
261264 -- flush the rest of the request body
262265 requestBody env $$ CL.sinkNull
263266 ResumableSource fromClient' _ <- liftIO getSource
264267
265− when keepAlive $ serveConnection'' fromClient'
268+ when keepAlive $ serveConnection'' istatus fromClient'
266269 Just intercept -> do
267270 liftIO $ T.pause th
268271 ResumableSource fromClient' _ <- liftIO getSource
269272 intercept fromClient' conn
270273
271−respondOnException :: Settings -> Cleaner -> Connection -> SockAddr -> IO () -> IO ()
272−respondOnException settings cleaner conn remoteHost' io = io `E.catch` \e@(SomeException _) -> do
273− _ <- runResourceT $ sendResponse settings cleaner blankRequest conn internalError
274+respondOnException :: IORef Bool -> Settings -> Cleaner -> Connection -> SockAddr -> IO () -> IO ()
275+respondOnException istatus settings cleaner conn remoteHost' io = io `E.catch` \e@(SomeException _) -> do
276+ status <- readIORef istatus
277+ when status $ do
278+ _ <- runResourceT $ sendResponse settings cleaner blankRequest conn internalError
279+ return ()
274280 throwIO e
275281 where
276282 blankRequest = Request H.methodGet H.http10 mempty mempty mempty 0 [] False remoteHost' [] [] (return mempty) mempty (KnownLength 0)
277283 internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"
278284
279−connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString
280−connSource Connection { connRecv = recv } th = src
285+connSource :: Connection -> T.Handle -> IORef Bool -> Source (ResourceT IO) ByteString
286+connSource Connection { connRecv = recv } th istatus = src
281287 where
282288 src = do
283289 bs <- liftIO recv
284290 unless (S.null bs) $ do
285− when (S.length bs >= 2048) $ liftIO $ T.tickle th
291+ liftIO $ do
292+ writeIORef istatus True
293+ when (S.length bs >= 2048) $ T.tickle th
286294 yield bs
287295 src
288296