Merge pull request #1009 from kazu-yamamoto/emfile-again

Waiting untill the number of FDs desreases on EMFILE
yesodweb · Oct 15, 2024 · da1d340 · da1d340
2 parents ec5e017 + 264c633
commit da1d340
Show file tree

Hide file tree

Showing 2 changed files with 24 additions and 12 deletions.
diff --git 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
@@ -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).