Make openFile more tolerant of async excs (#18832)

3 files changed, 79 insertions, 0 deletions

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, [''])