diff --git a/warp/Network/Wai/Handler/Warp/Counter.hs b/warp/Network/Wai/Handler/Warp/Counter.hs index 34dbcd976..09dcd6467 100644 --- a/warp/Network/Wai/Handler/Warp/Counter.hs +++ b/warp/Network/Wai/Handler/Warp/Counter.hs @@ -6,6 +6,7 @@ module Network.Wai.Handler.Warp.Counter ( waitForZero, increase, decrease, + waitForDecreased, ) where import Control.Concurrent.STM @@ -18,12 +19,19 @@ newCounter :: IO Counter newCounter = Counter <$> newTVarIO 0 waitForZero :: Counter -> IO () -waitForZero (Counter ref) = atomically $ do - x <- readTVar ref +waitForZero (Counter var) = atomically $ do + x <- readTVar var when (x > 0) retry +waitForDecreased :: Counter -> IO () +waitForDecreased (Counter var) = do + n0 <- atomically $ readTVar var + atomically $ do + n <- readTVar var + check (n < n0) + increase :: Counter -> IO () -increase (Counter ref) = atomically $ modifyTVar' ref $ \x -> x + 1 +increase (Counter var) = atomically $ modifyTVar' var $ \x -> x + 1 decrease :: Counter -> IO () -decrease (Counter ref) = atomically $ modifyTVar' ref $ \x -> x - 1 +decrease (Counter var) = atomically $ modifyTVar' var $ \x -> x - 1 diff --git a/warp/Network/Wai/Handler/Warp/Run.hs b/warp/Network/Wai/Handler/Warp/Run.hs index 0cde00d90..cef4b1c0f 100644 --- a/warp/Network/Wai/Handler/Warp/Run.hs +++ b/warp/Network/Wai/Handler/Warp/Run.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# LANGUAGE MultiWayIf #-} module Network.Wai.Handler.Warp.Run where @@ -13,7 +14,7 @@ import qualified Control.Exception import qualified Data.ByteString as S import Data.IORef (newIORef, readIORef) import Data.Streaming.Network (bindPortTCP) -import Foreign.C.Error (Errno (..), eCONNABORTED) +import Foreign.C.Error (Errno (..), eCONNABORTED, eMFILE) import GHC.IO.Exception (IOErrorType (..), IOException (..)) import Network.Socket ( SockAddr, @@ -305,13 +306,16 @@ acceptConnection set getConnMaker app counter ii = do case ex of Right x -> return $ Just x Left e -> do - let eConnAborted = getErrno eCONNABORTED - getErrno (Errno cInt) = cInt - if ioe_errno e == Just eConnAborted - then acceptNewConnection - else do - settingsOnException set Nothing $ toException e - return Nothing + let getErrno (Errno cInt) = cInt + isErrno err = ioe_errno e == Just (getErrno err) + if | isErrno eCONNABORTED -> acceptNewConnection + | isErrno eMFILE -> do + settingsOnException set Nothing $ toException e + waitForDecreased counter + acceptNewConnection + | otherwise -> do + settingsOnException set Nothing $ toException e + return Nothing -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown).