Make openFile more tolerant of async excs (#18832)

5 files changed, 96 insertions, 45 deletions

diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs
index 19f2bfd489..9e9fa428b8 100644
--- a/libraries/base/GHC/IO/FD.hs
+++ b/libraries/base/GHC/IO/FD.hs
@@ -167,46 +167,6 @@ writeBuf' fd buf = do
 -- -----------------------------------------------------------------------------
 -- opening files
 
--- | A wrapper for 'System.Posix.Internals.c_interruptible_open' that takes
--- two actions, @act1@ and @act2@, to perform after opening the file.
---
--- @act1@ is passed a file descriptor for the newly opened file. If
--- an exception occurs in @act1@, then the file will be closed.
--- @act1@ /must not/ close the file itself. If it does so and then
--- receives an exception, then the exception handler will attempt to
--- close it again, which is impermissable.
---
--- @act2@ is performed with asynchronous exceptions masked. It is passed a
--- function to restore the masking state and the result of @act1@.
--- It /must not/ throw an exception (or deliver one via an interruptible
--- operation) without first closing the file or arranging for it to be
--- closed. @act2@ /may/ close the file, but is not required to do so.
--- If @act2@ leaves the file open, then the file will remain open on
--- return from `c_interruptible_open_with`.
---
--- Code calling `c_interruptible_open_with` that wishes to install a finalizer
--- to close the file should do so in @act2@. Doing so in @act1@ could
--- potentially close the file in the finalizer first and then in the
--- exception handler.
-
-c_interruptible_open_with
-  :: System.Posix.Internals.CFilePath  -- ^ The file to open
-  -> CInt -- ^ The flags to pass to open
-  -> CMode -- ^ The permission mode to use for file creation
-  -> (CInt -> IO r) -- ^ @act1@: An action to perform on the file descriptor
-                    -- with the masking state restored and an exception
-                    -- handler that closes the file on exception.
-  -> ((forall x. IO x -> IO x) -> r -> IO s)
-                    -- ^ @act2@: An action to perform with async exceptions
-                    -- masked and no exception handler.
-  -> IO s
-c_interruptible_open_with path oflags mode act1 act2 =
-  mask $ \restore -> do
-    fd <- throwErrnoIfMinus1Retry "openFile" $
-             c_interruptible_open path oflags mode
-    r <- restore (act1 fd) `onException` c_close fd
-    act2 restore r
-
 -- | Open a file and make an 'FD' for it. Truncates the file to zero size when
 -- the `IOMode` is `WriteMode`.
 --
@@ -265,23 +225,32 @@ openFileWith filepath iomode non_blocking act1 act2 =
       oflags | non_blocking = oflags2 .|. nonblock_flags
              | otherwise    = oflags2
     in do
-      -- We want to be sure all the arguments to c_interruptible_open_with
+      -- We want to be sure all the arguments to c_interruptible_open
       -- are fully evaluated *before* it slips under a mask (assuming we're
       -- not already under a user-imposed mask).
       oflags' <- evaluate oflags
       -- NB. always use a safe open(), because we don't know whether open()
       -- will be fast or not.  It can be slow on NFS and FUSE filesystems,
       -- for example.
-      c_interruptible_open_with f oflags' 0o666 ( \ fileno -> do
+
+      mask $ \restore -> do
+        fileno <- throwErrnoIfMinus1Retry "openFile" $
+                c_interruptible_open f oflags' 0o666
+
         (fD,fd_type) <- mkFD fileno iomode Nothing{-no stat-}
                                 False{-not a socket-}
-                                non_blocking
+                                non_blocking `onException` c_close fileno
+
         -- we want to truncate() if this is an open in WriteMode, but only
         -- if the target is a RegularFile.  ftruncate() fails on special files
         -- like /dev/null.
+
         when (iomode == WriteMode && fd_type == RegularFile) $
-          setSize fD 0
-        act1 fD fd_type ) act2
+          setSize fD 0 `onException` close fD
+
+        carry <- restore (act1 fD fd_type) `onException` close fD
+
+        act2 restore carry
 
 -- | Open a file and make an 'FD' for it.  Truncates the file to zero
 -- size when the `IOMode` is `WriteMode`. This function is difficult
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index b6273f56de..aab8234e47 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -103,6 +103,9 @@
     call, ensuring that the call can be interrupted with `SIGINT` on POSIX
     systems.
 
+  * Make `openFile` more tolerant of asynchronous exceptions: more care taken
+    to release the file descriptor and the read/write lock (#18832)
+
   * Add `hGetContents'`, `getContents'`, and `readFile'` in `System.IO`:
     Strict IO variants of `hGetContents`, `getContents`, and `readFile`.
 
diff --git a/libraries/base/tests/IO/T18832.hs b/libraries/base/tests/IO/T18832.hs
new file mode 100644
index 0000000000..b4e1be12ea
--- /dev/null
+++ b/libraries/base/tests/IO/T18832.hs
@@ -0,0 +1,77 @@
+{-# Language ScopedTypeVariables #-}
+module Main where
+
+import Prelude
+import System.Directory
+import System.FilePath
+import System.IO
+import Control.Monad (forM_, forever, when)
+import Control.Exception
+import Control.Concurrent
+--import Data.Time
+
+-- How many `openHandle` calls in the test
+-- On a laptop:
+-- * when set to 1k, it ocasionally reproduces the failure
+-- * when set to 10k, it ocasionally fails to reproduce
+n :: Int
+n = 10000
+
+main :: IO ()
+main = test "."
+
+test :: FilePath -> IO ()
+test dir' = do
+  let dir = dir' </> "repro"
+  createDirectoryIfMissing True dir
+  availableNames <- newChan :: IO (Chan FilePath)
+  writeList2Chan availableNames [ dir </> "repro" ++ show (i :: Int) | i <- [1..30]]
+  toClose <- newChan :: IO (Chan (Handle, FilePath))
+  maybeDelete <- newChan :: IO (Chan FilePath)
+  deleter <- forkIO (getChanContents maybeDelete >>= mapM_ (recycle availableNames))
+  closer <- forkIO (getChanContents toClose >>= mapM_ (keepClosing availableNames))
+  resultMVar <- newEmptyMVar
+  openingThread <- keepOpening availableNames toClose maybeDelete `forkFinally`
+                      putMVar resultMVar
+  interrupter <- forkIO $ forever $ do
+    threadDelay (10^3)
+    throwTo openingThread Interrupt
+
+  result <- readMVar resultMVar
+
+  -- cleanup
+  mapM_ killThread [interrupter, deleter, closer]
+  removeDirectoryRecursive dir
+
+  either throwIO (const $ putStrLn "No failures observed - success") result
+
+
+keepOpening :: Chan FilePath -> Chan (Handle, FilePath) -> Chan FilePath -> IO ()
+keepOpening availableNames toClose maybeDelete =
+  uninterruptibleMask $ \ restore -> do
+    filepaths <- take n <$> getChanContents availableNames
+    forM_ filepaths $ \filepath -> do
+      --now <- getCurrentTime
+      h <- (Just <$> restore (openFile filepath WriteMode)) `catch` \(_ :: Interrupt) -> do
+            writeChan maybeDelete filepath
+            pure Nothing
+      --elapsed <- (`diffUTCTime` now) <$> getCurrentTime
+      --print elapsed
+      case h of
+        Nothing -> pure ()
+        Just h -> writeChan toClose (h, filepath)
+
+data Interrupt = Interrupt deriving (Show)
+instance Exception Interrupt
+
+recycle :: Chan FilePath -> FilePath -> IO ()
+recycle availableNames name = do
+  exist <- doesFileExist name
+  when exist $ removeFile name
+  writeChan availableNames name
+
+keepClosing :: Chan FilePath -> (Handle, FilePath) -> IO ()
+keepClosing availableNames (handle, name) = do
+  hClose handle
+  removeFile name
+  writeChan availableNames name
diff --git a/libraries/base/tests/IO/T18832.stdout b/libraries/base/tests/IO/T18832.stdout
new file mode 100644
index 0000000000..359eeca7be
--- /dev/null
+++ b/libraries/base/tests/IO/T18832.stdout
@@ -0,0 +1 @@
+No failures observed - success
diff --git a/libraries/base/tests/IO/all.T b/libraries/base/tests/IO/all.T
index 40e9dbf35f..2d4c85700f 100644
--- a/libraries/base/tests/IO/all.T
+++ b/libraries/base/tests/IO/all.T
@@ -150,3 +150,4 @@ test('T17414',
 test('T17510', expect_broken(17510), compile_and_run, [''])
 test('bytestringread001', extra_run_opts('test.data'), compile_and_run, [''])
 test('T17912', [only_ways(['threaded1']), when(opsys('mingw32'),expect_broken(1))], compile_and_run, [''])
+test('T18832', only_ways(['threaded1']), compile_and_run, [''])