Make openFile exception safe

* `openFile` could sometimes leak file descriptors if it
  received an asynchronous exception (#19114, #19115). Fix this
  on POSIX.

* `openFile` and more importantly `openFileBlocking` could not
  be interrupted effectively during the `open` system call (#17912).
  Fix this on POSIX.

* Implement `readFile'` using `withFile` to ensure the file is closed promptly on exception.

* Avoid `bracket` in `withFile`, reducing the duration of masking.

Closes #19130.

Addresses #17912, #19114, and #19115 on POSIX systems, but not
on Windows.

2 files changed, 69 insertions, 18 deletions

diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs
index c5dfe057ba..59390c7ab4 100644
--- a/libraries/base/System/IO.hs
+++ b/libraries/base/System/IO.hs
@@ -347,7 +347,9 @@ readFile name   =  openFile name ReadMode >>= hGetContents
 -- @since 4.15.0.0
 
 readFile'       :: FilePath -> IO String
-readFile' name  =  openFile name ReadMode >>= hGetContents'
+-- There's a bit of overkill here—both withFile and
+-- hGetContents' will close the file in the end.
+readFile' name  =  withFile name ReadMode hGetContents'
 
 -- | The computation 'writeFile' @file str@ function writes the string @str@,
 -- to the file @file@.
@@ -413,21 +415,6 @@ hReady h        =  hWaitForInput h 0
 hPrint          :: Show a => Handle -> a -> IO ()
 hPrint hdl      =  hPutStrLn hdl . show
 
--- | @'withFile' name mode act@ opens a file using 'openFile' and passes
--- the resulting handle to the computation @act@.  The handle will be
--- closed on exit from 'withFile', whether by normal termination or by
--- raising an exception.  If closing the handle raises an exception, then
--- this exception will be raised by 'withFile' rather than any exception
--- raised by @act@.
-withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
-withFile name mode = bracket (openFile name mode) hClose
-
--- | @'withBinaryFile' name mode act@ opens a file using 'openBinaryFile'
--- and passes the resulting handle to the computation @act@.  The handle
--- will be closed on exit from 'withBinaryFile', whether by normal
--- termination or by raising an exception.
-withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
-withBinaryFile name mode = bracket (openBinaryFile name mode) hClose
 
 -- ---------------------------------------------------------------------------
 -- fixIO
diff --git a/libraries/base/System/Posix/Internals.hs b/libraries/base/System/Posix/Internals.hs
index 4bdeabe1bd..2772a66c75 100644
--- a/libraries/base/System/Posix/Internals.hs
+++ b/libraries/base/System/Posix/Internals.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE InterruptibleFFI #-}
 {-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
 {-# OPTIONS_HADDOCK not-home #-}
 
 -----------------------------------------------------------------------------
@@ -356,9 +359,70 @@ type CFilePath = CWString
 foreign import ccall unsafe "HsBase.h __hscore_open"
    c_open :: CFilePath -> CInt -> CMode -> IO CInt
 
--- e.g. use `interruptible` rather than `safe` due to #17912.
+-- | The same as 'c_safe_open', but an /interruptible operation/
+-- as described in "Control.Exception"—it respects `uninterruptibleMask`
+-- but not `mask`.
+--
+-- We want to be able to interrupt an openFile call if
+-- it's expensive (NFS, FUSE, etc.), and we especially
+-- need to be able to interrupt a blocking open call.
+-- See #17912.
+c_interruptible_open :: CFilePath -> CInt -> CMode -> IO CInt
+c_interruptible_open filepath oflags mode =
+  getMaskingState >>= \case
+    -- If we're in an uninterruptible mask, there's basically
+    -- no point in using an interruptible FFI call. The open system call
+    -- will be interrupted, but the exception won't be delivered
+    -- unless the caller manually futzes with the masking state. So
+    -- then the caller (assuming they're following the usual conventions)
+    -- will retry the call (in response to EINTR), and we've just
+    -- wasted everyone's time.
+    MaskedUninterruptible -> c_safe_open_ filepath oflags mode
+    _ -> do
+      open_res <- c_interruptible_open_ filepath oflags mode
+      -- c_interruptible_open_ is an interruptible foreign call.
+      -- If the call is interrupted by an exception handler
+      -- before the system call has returned (so the file is
+      -- not yet open), we want to deliver the exception.
+      -- In point of fact, we deliver any pending exception
+      -- here regardless of the *reason* the system call
+      -- fails.
+      when (open_res == -1) $
+        if hostIsThreaded
+          then
+            -- Control.Exception.allowInterrupt, inlined to avoid
+            -- messing with any Haddock links.
+            interruptible (pure ())
+          else
+            -- Try to make this work somewhat better on the non-threaded
+            -- RTS. See #8684. This inlines the definition of `yield`; module
+            -- dependencies look pretty hairy here and I don't want to make
+            -- things worse for one little wrapper.
+            interruptible (IO $ \s -> (# yield# s, () #))
+      pure open_res
+
 foreign import ccall interruptible "HsBase.h __hscore_open"
-   c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt
+   c_interruptible_open_ :: CFilePath -> CInt -> CMode -> IO CInt
+
+-- | Consult the RTS to find whether it is threaded.
+hostIsThreaded :: Bool
+hostIsThreaded = rtsIsThreaded_ /= 0
+
+foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int
+
+c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt
+c_safe_open filepath oflags mode =
+  getMaskingState >>= \case
+    -- When exceptions are unmasked, we use an interruptible
+    -- open call. If the system call is successfully
+    -- interrupted, the situation will be the same as if
+    -- the exception had arrived before this function was
+    -- called.
+    Unmasked -> c_interruptible_open_ filepath oflags mode
+    _ -> c_safe_open_ filepath oflags mode
+
+foreign import ccall safe "HsBase.h __hscore_open"
+   c_safe_open_ :: CFilePath -> CInt -> CMode -> IO CInt
 
 foreign import ccall unsafe "HsBase.h __hscore_fstat"
    c_fstat :: CInt -> Ptr CStat -> IO CInt