@@ -293,7 +293,7 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->
293293 serve unmask ref (conn, transport) = bracket register cancel $ \th -> do
294294 let ii1 = toInternalInfo1 ii0 th
295295 -- We now have fully registered a connection close handler in
296− -- the case of all exceptions, so it is safe to one again
296+ -- the case of all exceptions, so it is safe to once again
297297 -- allow async exceptions.
298298 unmask .
299299 -- Call the user-supplied code for connection open and
@@ -396,9 +396,11 @@ serveConnection conn ii1 origAddr transport settings app = do
396396
397397 sendErrorResponse req istatus e = do
398398 status <- readIORef istatus
399− when (shouldSendErrorResponse e && status) $ do
400− let ii = toInternalInfo ii1 0 -- dummy
401− void $ sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)
399+ if (shouldSendErrorResponse e && status)
400+ then do
401+ let ii = toInternalInfo ii1 0 -- dummy
402+ sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)
403+ else return False
402404
403405 dummyreq addr = defaultRequest { remoteHost = addr }
404406
@@ -409,8 +411,6 @@ serveConnection conn ii1 origAddr transport settings app = do
409411 let req = req' { isSecure = isTransportSecure transport }
410412 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii
411413 `E.catch` \e -> do
412− -- Call the user-supplied exception handlers, passing the request.
413− sendErrorResponse req istatus e
414414 settingsOnException settings (Just req) e
415415 -- Don't throw the error again to prevent calling settingsOnException twice.
416416 return False
@@ -433,7 +433,7 @@ serveConnection conn ii1 origAddr transport settings app = do
433433 -- creating the request, we need to make sure that we don't get
434434 -- an async exception before calling the ResponseSource.
435435 keepAliveRef <- newIORef $ error "keepAliveRef not filled"
436− _ <- app req $ \res -> do
436+ r <- E.try $ app req $ \res -> do
437437 T.resume th
438438 -- FIXME consider forcing evaluation of the res here to
439439 -- send more meaningful error messages to the user.
@@ -442,21 +442,29 @@ serveConnection conn ii1 origAddr transport settings app = do
442442 keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res
443443 writeIORef keepAliveRef keepAlive
444444 return ResponseReceived
445+ case r of
446+ Right ResponseReceived -> return ()
447+ Left e@(SomeException _)
448+ | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'
449+ | otherwise -> do
450+ keepAlive <- sendErrorResponse req istatus e
451+ settingsOnException settings (Just req) e
452+ writeIORef keepAliveRef keepAlive
453+
445454 keepAlive <- readIORef keepAliveRef
446455
447456 -- We just send a Response and it takes a time to
448457 -- receive a Request again. If we immediately call recv,
449− -- it is likely to fail and the IO manager works.
450− -- It is very costly. So, we yield to another Haskell
458+ -- it is likely to fail and cause the IO manager to do some work.
459+ -- It is very costly, so we yield to another Haskell
451460 -- thread hoping that the next Request will arrive
452461 -- when this Haskell thread will be re-scheduled.
453462 -- This improves performance at least when
454463 -- the number of cores is small.
455464 Conc.yield
456465
457− if not keepAlive then
458− return False
459− else
466+ if keepAlive
467+ then
460468 -- If there is an unknown or large amount of data to still be read
461469 -- from the request body, simple drop this connection instead of
462470 -- reading it all in to satisfy a keep-alive request.
@@ -482,6 +490,8 @@ serveConnection conn ii1 origAddr transport settings app = do
482490 else
483491 return False
484492 Nothing -> tryKeepAlive
493+ else
494+ return False
485495
486496flushEntireBody :: IO ByteString -> IO ()
487497flushEntireBody src =