@@ -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 conn th istatus
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
@@ -255,34 +257,44 @@ serveConnection timeoutHandle settings cleaner port app conn remoteHost' =
255257 keepAlive <- innerRunResourceT $ do
256258 res <- app env
257259
258− liftIO $ T.resume th
260+ liftIO $ do
261+ T.resume th
262+ -- FIXME consider forcing evaluation of the res here to
263+ -- send more meaningful error messages to the user.
264+ -- However, it may affect performance.
265+ writeIORef istatus False
259266 sendResponse settings cleaner env conn res
260267
261268 -- flush the rest of the request body
262269 requestBody env $$ CL.sinkNull
263270 ResumableSource fromClient' _ <- liftIO getSource
264271
265− when keepAlive $ serveConnection'' fromClient'
272+ when keepAlive $ serveConnection'' istatus fromClient'
266273 Just intercept -> do
267274 liftIO $ T.pause th
268275 ResumableSource fromClient' _ <- liftIO getSource
269276 intercept fromClient' conn
270277
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
278+respondOnException :: IORef Bool -> Settings -> Cleaner -> Connection -> SockAddr -> IO () -> IO ()
279+respondOnException istatus settings cleaner conn remoteHost' io = io `E.catch` \e@(SomeException _) -> do
280+ status <- readIORef istatus
281+ when status $ do
282+ _ <- runResourceT $ sendResponse settings cleaner blankRequest conn internalError
283+ return ()
274284 throwIO e
275285 where
276286 blankRequest = Request H.methodGet H.http10 mempty mempty mempty 0 [] False remoteHost' [] [] (return mempty) mempty (KnownLength 0)
277287 internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"
278288
279−connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString
280−connSource Connection { connRecv = recv } th = src
289+connSource :: Connection -> T.Handle -> IORef Bool -> Source (ResourceT IO) ByteString
290+connSource Connection { connRecv = recv } th istatus = src
281291 where
282292 src = do
283293 bs <- liftIO recv
284294 unless (S.null bs) $ do
285− when (S.length bs >= 2048) $ liftIO $ T.tickle th
295+ liftIO $ do
296+ writeIORef istatus True
297+ when (S.length bs >= 2048) $ T.tickle th
286298 yield bs
287299 src
288300