warp 1.3.10.1 → 1.3.10.2

raw patch · 2 files changed

+27/−15 lines, 2 files

Files

• Network/Wai/Handler/Warp/Run.hs +26/−14
• warp.cabal +1/−1

@@ -27,6 +27,7 @@ import Network.Wai.Handler.Warp.Settings import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types+import Data.IORef (IORef, newIORef, readIORef, writeIORef)  -- Sock.recv first tries to call recvfrom() optimistically. -- If EAGAIN returns, it polls incoming data with epoll/kqueue.@@ -234,19 +235,20 @@                 -> Settings                 -> Cleaner                 -> Port -> Application -> Connection -> SockAddr-> IO ()-serveConnection timeoutHandle settings cleaner port app conn remoteHost' =-    respondOnException settings cleaner conn remoteHost' $-        runResourceT serveConnection'+serveConnection timeoutHandle settings cleaner port app conn remoteHost' = do+    istatus <- newIORef False+    respondOnException istatus settings cleaner conn remoteHost' $+        runResourceT (serveConnection' istatus)   where     innerRunResourceT         | settingsResourceTPerRequest settings = lift . runResourceT         | otherwise = id     th = threadHandle cleaner -    serveConnection' :: ResourceT IO ()-    serveConnection' = serveConnection'' $ connSource conn th+    serveConnection' :: IORef Bool -> ResourceT IO ()+    serveConnection' istatus = serveConnection'' istatus $ connSource conn th istatus -    serveConnection'' fromClient = do+    serveConnection'' istatus fromClient = do         (env, getSource) <- parseRequestInternal conn timeoutHandle port remoteHost' fromClient         case settingsIntercept settings env of             Nothing -> do@@ -255,34 +257,44 @@                 keepAlive <- innerRunResourceT $ do                     res <- app env -                    liftIO $ T.resume th+                    liftIO $ do+                        T.resume th+                        -- FIXME consider forcing evaluation of the res here to+                        -- send more meaningful error messages to the user.+                        -- However, it may affect performance.+                        writeIORef istatus False                     sendResponse settings cleaner env conn res                  -- flush the rest of the request body                 requestBody env $$ CL.sinkNull                 ResumableSource fromClient' _ <- liftIO getSource -                when keepAlive $ serveConnection'' fromClient'+                when keepAlive $ serveConnection'' istatus fromClient'             Just intercept -> do                 liftIO $ T.pause th                 ResumableSource fromClient' _ <- liftIO getSource                 intercept fromClient' conn -respondOnException :: Settings -> Cleaner -> Connection -> SockAddr -> IO () -> IO ()-respondOnException settings cleaner conn remoteHost' io = io `E.catch` \e@(SomeException _) -> do-    _ <- runResourceT $ sendResponse settings cleaner blankRequest conn internalError+respondOnException :: IORef Bool -> Settings -> Cleaner -> Connection -> SockAddr -> IO () -> IO ()+respondOnException istatus settings cleaner conn remoteHost' io = io `E.catch` \e@(SomeException _) -> do+    status <- readIORef istatus+    when status $ do+        _ <- runResourceT $ sendResponse settings cleaner blankRequest conn internalError+        return ()     throwIO e   where     blankRequest = Request H.methodGet H.http10 mempty mempty mempty 0 [] False remoteHost' [] [] (return mempty) mempty (KnownLength 0)     internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong" -connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString-connSource Connection { connRecv = recv } th = src+connSource :: Connection -> T.Handle -> IORef Bool -> Source (ResourceT IO) ByteString+connSource Connection { connRecv = recv } th istatus = src   where     src = do         bs <- liftIO recv         unless (S.null bs) $ do-            when (S.length bs >= 2048) $ liftIO $ T.tickle th+            liftIO $ do+                writeIORef istatus True+                when (S.length bs >= 2048) $ T.tickle th             yield bs             src 

@@ -1,5 +1,5 @@ Name:                warp-Version:             1.3.10.1+Version:             1.3.10.2 Synopsis:            A fast, light-weight web server for WAI applications. License:             MIT License-file:        LICENSE