@@ -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
@@ -409,11 +409,22 @@ serveConnection conn ii1 origAddr transport settings app = do
409409 let req = req' { isSecure = isTransportSecure transport }
410410 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii
411411 `E.catch` \e -> do
412− -- Call the user-supplied exception handlers, passing the request.
413− sendErrorResponse req istatus e
414− settingsOnException settings (Just req) e
415− -- Don't throw the error again to prevent calling settingsOnException twice.
416− return False
412+ -- Attempt to unwrap exception and use it to determine
413+ -- safety of keeping exception alive
414+ case fromException e of
415+ Nothing -> do
416+ -- Call the user-supplied exception handlers, passing the request.
417+ sendErrorResponse req istatus e
418+ settingsOnException settings (Just req) e
419+ -- Don't throw the error again to prevent calling settingsOnException twice.
420+ let (isPersist, _) = infoFromRequest req idxhdr
421+ return isPersist
422+ Just (ExceptionInsideResponseBody e') -> do
423+ -- Call the user-supplied exception handlers, passing the request.
424+ sendErrorResponse req istatus e'
425+ settingsOnException settings (Just req) e'
426+ -- Don't throw the error again to prevent calling settingsOnException twice.
427+ return False
417428
418429 -- When doing a keep-alive connection, the other side may just
419430 -- close the connection. We don't want to treat that as an
@@ -446,17 +457,16 @@ serveConnection conn ii1 origAddr transport settings app = do
446457
447458 -- We just send a Response and it takes a time to
448459 -- 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
460+ -- it is likely to fail and cause the IO manager to do some work.
461+ -- It is very costly, so we yield to another Haskell
451462 -- thread hoping that the next Request will arrive
452463 -- when this Haskell thread will be re-scheduled.
453464 -- This improves performance at least when
454465 -- the number of cores is small.
455466 Conc.yield
456467
457− if not keepAlive then
458− return False
459− else
468+ if keepAlive
469+ then
460470 -- If there is an unknown or large amount of data to still be read
461471 -- from the request body, simple drop this connection instead of
462472 -- reading it all in to satisfy a keep-alive request.
@@ -482,6 +492,8 @@ serveConnection conn ii1 origAddr transport settings app = do
482492 else
483493 return False
484494 Nothing -> tryKeepAlive
495+ else
496+ return False
485497
486498flushEntireBody :: IO ByteString -> IO ()
487499flushEntireBody src =