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.

9 files changed, 432 insertions, 118 deletions

diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst
index e06aa5b11b..06134387f3 100644
--- a/docs/users_guide/9.2.1-notes.rst
+++ b/docs/users_guide/9.2.1-notes.rst
@@ -197,3 +197,6 @@ Runtime system
 
     charVal :: forall n proxy. KnownChar n => proxy n -> Char
     charVal' :: forall n. KnownChar n => Proxy# n -> Char
+
+- On POSIX, ``System.IO.openFile`` can no longer leak a file descriptor if it
+  is interrupted by an asynchronous exception (#19114, #19115).
diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs
index 277a7b41c2..19f2bfd489 100644
--- a/libraries/base/GHC/IO/FD.hs
+++ b/libraries/base/GHC/IO/FD.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP
            , NoImplicitPrelude
            , BangPatterns
+           , RankNTypes
   #-}
 {-# OPTIONS_GHC -Wno-identities #-}
 -- Whether there are identities depends on the platform
@@ -22,7 +23,7 @@
 
 module GHC.IO.FD (
         FD(..),
-        openFile, mkFD, release,
+        openFileWith, openFile, mkFD, release,
         setNonBlockingMode,
         readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
         stdin, stdout, stderr
@@ -166,17 +167,86 @@ writeBuf' fd buf = do
 -- -----------------------------------------------------------------------------
 -- opening files
 
--- | Open a file and make an 'FD' for it.  Truncates the file to zero
--- size when the `IOMode` is `WriteMode`.
-openFile
+-- | 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`.
+--
+-- `openFileWith` takes two actions, @act1@ and @act2@, to perform after
+-- opening the file.
+--
+-- @act1@ is passed a file descriptor and I/O device type 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 `openFileWith`.
+--
+-- Code calling `openFileWith` 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. See
+-- 'GHC.IO.Handle.FD.openFile'' for an example of this use. Regardless, the
+-- caller is responsible for ensuring that the file is eventually closed,
+-- perhaps using 'Control.Exception.bracket'.
+
+openFileWith
   :: FilePath -- ^ file to open
   -> IOMode   -- ^ mode in which to open the file
   -> Bool     -- ^ open the file in non-blocking mode?
-  -> IO (FD,IODeviceType)
-
-openFile filepath iomode non_blocking =
+  -> (FD -> IODeviceType -> 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
+openFileWith filepath iomode non_blocking act1 act2 =
   withFilePath filepath $ \ f ->
-
     let
       oflags1 = case iomode of
                   ReadMode      -> read_flags
@@ -195,25 +265,38 @@ openFile filepath iomode non_blocking =
       oflags | non_blocking = oflags2 .|. nonblock_flags
              | otherwise    = oflags2
     in do
+      -- We want to be sure all the arguments to c_interruptible_open_with
+      -- 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
+        (fD,fd_type) <- mkFD fileno iomode Nothing{-no stat-}
+                                False{-not a socket-}
+                                non_blocking
+        -- 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
 
-    -- 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.
-    fd <- throwErrnoIfMinus1Retry "openFile" $ c_safe_open f oflags 0o666
-
-    (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
-                            False{-not a socket-}
-                            non_blocking
-            `catchAny` \e -> do _ <- c_close fd
-                                throwIO e
-
-    -- 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
-
-    return (fD,fd_type)
+-- | Open a file and make an 'FD' for it.  Truncates the file to zero
+-- size when the `IOMode` is `WriteMode`. This function is difficult
+-- to use without potentially leaking the file descriptor on exception.
+-- In particular, it must be used with exceptions masked, which is a
+-- bit rude because the thread will be uninterruptible while the file
+-- path is being encoded. Use 'openFileWith' instead.
+openFile
+  :: FilePath -- ^ file to open
+  -> IOMode   -- ^ mode in which to open the file
+  -> Bool     -- ^ open the file in non-blocking mode?
+  -> IO (FD,IODeviceType)
+openFile filepath iomode non_blocking =
+  openFileWith filepath iomode non_blocking
+    (\ fd fd_type -> pure (fd, fd_type)) (\_ r -> pure r)
 
 std_flags, output_flags, read_flags, write_flags, rw_flags,
     append_flags, nonblock_flags :: CInt
diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs
index 2ad608b0df..9bfb7df4cb 100644
--- a/libraries/base/GHC/IO/Handle.hs
+++ b/libraries/base/GHC/IO/Handle.hs
@@ -85,27 +85,13 @@ import Data.Typeable
 -- If 'hClose' fails for any reason, any further operations (apart from
 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
 -- closed.
-
+--
+-- 'hClose' is an /interruptible operation/ in the sense described in
+-- "Control.Exception". If 'hClose' is interrupted by an asynchronous
+-- exception in the process of flushing its buffers, then the I/O device
+-- (e.g., file) will be closed anyway.
 hClose :: Handle -> IO ()
-hClose h@(FileHandle _ m)     = do
-  mb_exc <- hClose' h m
-  hClose_maybethrow mb_exc h
-hClose h@(DuplexHandle _ r w) = do
-  excs <- mapM (hClose' h) [r,w]
-  hClose_maybethrow (listToMaybe (catMaybes excs)) h
-
-hClose_maybethrow :: Maybe SomeException -> Handle -> IO ()
-hClose_maybethrow Nothing  h = return ()
-hClose_maybethrow (Just e) h = hClose_rethrow e h
-
-hClose_rethrow :: SomeException -> Handle -> IO ()
-hClose_rethrow e h =
-  case fromException e of
-    Just ioe -> ioError (augmentIOError ioe "hClose" h)
-    Nothing  -> throwIO e
-
-hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
-hClose' h m = withHandle' "hClose" h m $ hClose_help
+hClose = hClose_impl
 
 -----------------------------------------------------------------------------
 -- Detecting and changing the size of a file
diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs
index 122331f17d..907408d633 100644
--- a/libraries/base/GHC/IO/Handle/FD.hs
+++ b/libraries/base/GHC/IO/Handle/FD.hs
@@ -17,7 +17,9 @@
 
 module GHC.IO.Handle.FD ( 
   stdin, stdout, stderr,
-  openFile, openBinaryFile, openFileBlocking,
+  openFile, withFile,
+  openBinaryFile, withBinaryFile,
+  openFileBlocking, withFileBlocking,
   mkHandleFromFD, fdToHandle, fdToHandle', handleToFd
  ) where
 
@@ -138,6 +140,9 @@ addFilePathToIOError fun fp ioe
 --  * 'System.IO.Error.isPermissionError' if the user does not have permission
 --     to open the file.
 --
+-- On POSIX systems, 'openFile' is an /interruptible operation/ as
+-- described in "Control.Exception".
+--
 -- Note: if you will be working with files containing binary data, you'll want to
 -- be using 'openBinaryFile'.
 openFile :: FilePath -> IOMode -> IO Handle
@@ -146,22 +151,49 @@ openFile fp im =
     (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True)
     (\e -> ioError (addFilePathToIOError "openFile" fp e))
 
+-- | @'withFile' name mode act@ opens a file like '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 fp im act =
+  catchException
+    (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True act)
+    (\e -> ioError (addFilePathToIOError "withFile" fp e))
+
 -- | Like 'openFile', but opens the file in ordinary blocking mode.
 -- This can be useful for opening a FIFO for writing: if we open in
 -- non-blocking mode then the open will fail if there are no readers,
 -- whereas a blocking open will block until a reader appear.
--- 
+--
 -- Note: when blocking happens, an OS thread becomes tied up with the
 -- processing, so the program must have at least another OS thread if
 -- it wants to unblock itself. By corollary, a non-threaded runtime
 -- will need a process-external trigger in order to become unblocked.
 --
+-- On POSIX systems, 'openFileBlocking' is an /interruptible operation/ as
+-- described in "Control.Exception".
+--
 -- @since 4.4.0.0
 openFileBlocking :: FilePath -> IOMode -> IO Handle
 openFileBlocking fp im =
   catchException
     (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False)
-    (\e -> ioError (addFilePathToIOError "openFile" fp e))
+    (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e))
+
+-- | @'withFileBlocking' name mode act@ opens a file like 'openFileBlocking'
+-- and passes the resulting handle to the computation @act@.  The handle will
+-- be closed on exit from 'withFileBlocking', 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@.
+withFileBlocking :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withFileBlocking fp im act =
+  catchException
+    (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False act)
+    (\e -> ioError (addFilePathToIOError "withFileBlocking" fp e))
 
 -- | Like 'openFile', but open the file in binary mode.
 -- On Windows, reading a file in text mode (which is the default)
@@ -172,35 +204,72 @@ openFileBlocking fp im =
 -- treatment of end-of-line and end-of-file characters.
 -- (See also 'System.IO.hSetBinaryMode'.)
 
+-- On POSIX systems, 'openBinaryFile' is an /interruptible operation/ as
+-- described in "Control.Exception".
 openBinaryFile :: FilePath -> IOMode -> IO Handle
 openBinaryFile fp m =
   catchException
     (openFile' fp m True True)
     (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
 
-openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle
-openFile' filepath iomode binary non_blocking = do
+-- | A version of `openBinaryFile` that takes an action to perform
+-- with the handle. If an exception occurs in the action, then
+-- the file will be closed automatically. The action /should/
+-- close the file when finished with it so the file does not remain
+-- open until the garbage collector collects the handle.
+withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withBinaryFile fp im act =
+  catchException
+    (withFile' fp im True True act)
+    (\e -> ioError (addFilePathToIOError "withBinaryFile" fp e))
+
+-- | Open a file and perform an action with it. If the action throws an
+-- exception, then the file will be closed. If the last argument is 'True',
+-- then the file will be closed on successful completion as well. We use this to
+-- implement both the `withFile` family of functions (via `withFile'`) and the
+-- `openFile` family (via `openFile'`).
+withOpenFile' :: String -> IOMode -> Bool -> Bool -> (Handle -> IO r) -> Bool -> IO r
+withOpenFile' filepath iomode binary non_blocking act close_finally =
   -- first open the file to get an FD
-  (fd, fd_type) <- FD.openFile filepath iomode non_blocking
-
-  mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding
+  FD.openFileWith filepath iomode non_blocking (\fd fd_type -> do
+
+      mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding
+
+      -- Then use it to make a Handle. If this fails, openFileWith
+      -- will take care of closing the file.
+      mkHandleFromFDNoFinalizer fd fd_type filepath iomode
+                       False {- do not *set* non-blocking mode -}
+                       mb_codec)
+
+    -- Add a finalizer to the handle. This is done under a mask,
+    -- so there are no asynchronous exceptions, and (satisfying
+    -- the conditions of openFileWith), addHandleFinalizer
+    -- cannot throw a synchronous exception.
+    (\restore hndl -> do
+        addHandleFinalizer hndl handleFinalizer
+        r <- restore (act hndl) `onException` hClose_impl hndl
+        when close_finally $ hClose_impl hndl
+        pure r
+        )
 
-  -- then use it to make a Handle
-  mkHandleFromFD fd fd_type filepath iomode
-                   False {- do not *set* non-blocking mode -}
-                   mb_codec
-            `onException` IODevice.close fd
-        -- NB. don't forget to close the FD if mkHandleFromFD fails, otherwise
-        -- this FD leaks.
         -- ASSERT: if we just created the file, then fdToHandle' won't fail
         -- (so we don't need to worry about removing the newly created file
         --  in the event of an error).
 
+-- | Open a file and perform an action with it. When the action
+-- completes or throws/receives an exception, the file will be closed.
+withFile' :: String -> IOMode -> Bool -> Bool -> (Handle -> IO r) -> IO r
+withFile' filepath iomode binary non_blocking act =
+  withOpenFile' filepath iomode binary non_blocking act True
+
+openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle
+openFile' filepath iomode binary non_blocking =
+  withOpenFile' filepath iomode binary non_blocking pure False
 
 -- ---------------------------------------------------------------------------
 -- Converting file descriptors from/to Handles
 
-mkHandleFromFD
+mkHandleFromFDNoFinalizer
    :: FD.FD
    -> IODeviceType
    -> FilePath  -- a string describing this file descriptor (e.g. the filename)
@@ -209,7 +278,7 @@ mkHandleFromFD
    -> Maybe TextEncoding
    -> IO Handle
 
-mkHandleFromFD fd0 fd_type filepath iomode set_non_blocking mb_codec
+mkHandleFromFDNoFinalizer fd0 fd_type filepath iomode set_non_blocking mb_codec
   = do
 #if !defined(mingw32_HOST_OS)
     -- turn on non-blocking mode
@@ -233,11 +302,24 @@ mkHandleFromFD fd0 fd_type filepath iomode set_non_blocking mb_codec
            -- only *Streams* can be DuplexHandles.  Other read/write
            -- Handles must share a buffer.
            | ReadWriteMode <- iomode -> 
-                mkDuplexHandle fd filepath mb_codec nl
-                   
+                mkDuplexHandleNoFinalizer fd filepath mb_codec nl
 
         _other -> 
-           mkFileHandle fd filepath iomode mb_codec nl
+           mkFileHandleNoFinalizer fd filepath iomode mb_codec nl
+
+mkHandleFromFD
+   :: FD.FD
+   -> IODeviceType
+   -> FilePath  -- a string describing this file descriptor (e.g. the filename)
+   -> IOMode
+   -> Bool      --  *set* non-blocking mode on the FD
+   -> Maybe TextEncoding
+   -> IO Handle
+mkHandleFromFD fd0 fd_type filepath iomode set_non_blocking mb_codec = do
+  h <- mkHandleFromFDNoFinalizer fd0 fd_type filepath iomode
+                                 set_non_blocking mb_codec
+  addHandleFinalizer h handleFinalizer
+  pure h
 
 -- | Old API kept to avoid breaking clients
 fdToHandle' :: CInt
diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs
index d5f53b7dd5..1bdb47b7ca 100644
--- a/libraries/base/GHC/IO/Handle/Internals.hs
+++ b/libraries/base/GHC/IO/Handle/Internals.hs
@@ -32,7 +32,9 @@ module GHC.IO.Handle.Internals (
   wantWritableHandle, wantReadableHandle, wantReadableHandle_,
   wantSeekableHandle,
 
-  mkHandle, mkFileHandle, mkDuplexHandle,
+  mkHandle,
+  mkFileHandle, mkFileHandleNoFinalizer, mkDuplexHandle, mkDuplexHandleNoFinalizer,
+  addHandleFinalizer,
   openTextEncoding, closeTextCodecs, initBufferState,
   dEFAULT_CHAR_BUFFER_SIZE,
 
@@ -47,7 +49,7 @@ module GHC.IO.Handle.Internals (
   ioe_EOF, ioe_notReadable, ioe_notWritable,
   ioe_finalizedHandle, ioe_bufsiz,
 
-  hClose_help, hLookAhead_,
+  hClose_impl, hClose_help, hLookAhead_,
 
   HandleFinalizer, handleFinalizer,
 
@@ -90,15 +92,18 @@ c_DEBUG_DUMP = False
 
 type HandleFinalizer = FilePath -> MVar Handle__ -> IO ()
 
-newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle
-newFileHandle filepath mb_finalizer hc = do
-  m <- newMVar hc
-  case mb_finalizer of
-    Just finalizer -> do debugIO $ "Registering finalizer: " ++ show filepath
-                         addMVarFinalizer m (finalizer filepath m)
-    Nothing        -> do debugIO $ "No finalizer: " ++ show filepath
-                         return ()
-  return (FileHandle filepath m)
+-- | Add a finalizer to a 'Handle'. Specifically, the finalizer
+-- will be added to the 'MVar' of a file handle or the write-side
+-- 'MVar' of a duplex handle. See Handle Finalizers for details.
+addHandleFinalizer :: Handle -> HandleFinalizer -> IO ()
+addHandleFinalizer handle finalizer = do
+  debugIO $ "Registering finalizer: " ++ show filepath
+  addMVarFinalizer mv (finalizer filepath mv)
+  where
+    !(filepath, !mv) = case handle of
+      FileHandle fp m -> (fp, m)
+      DuplexHandle fp _ write_m -> (fp, write_m)
+
 
 -- ---------------------------------------------------------------------------
 -- Working with Handles
@@ -649,16 +654,17 @@ flushByteReadBuffer h_@Handle__{..} = do
   the offset accordingly. This is only required for WINIO.
 -}
 
-mkHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
+-- | Make an @'MVar' 'Handle__'@ for use in a 'Handle'. This function
+-- does not install a finalizer; that must be done by the caller.
+mkHandleMVar :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
          -> FilePath
          -> HandleType
          -> Bool                     -- buffered?
          -> Maybe TextEncoding
          -> NewlineMode
-         -> Maybe HandleFinalizer
          -> Maybe (MVar Handle__)
-         -> IO Handle
-mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side =
+         -> IO (MVar Handle__)
+mkHandleMVar dev filepath ha_type buffered mb_codec nl other_side =
    openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do
 
    let !buf_state = initBufferState ha_type
@@ -675,8 +681,7 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side =
 
    spares <- newIORef BufferListNil
    debugIO $ "making handle for " ++ filepath
-   newFileHandle filepath finalizer
-            (Handle__ { haDevice = dev,
+   newMVar $ Handle__ { haDevice = dev,
                         haType = ha_type,
                         haBufferMode = bmode,
                         haByteBuffer = bbufref,
@@ -689,7 +694,7 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side =
                         haInputNL = inputNL nl,
                         haOutputNL = outputNL nl,
                         haOtherSide = other_side
-                      })
+                      }
   where
     -- See Note [Making offsets for append]
     initHandleOffset
@@ -699,6 +704,45 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side =
           return (fromIntegral size :: Word64)
       | otherwise = return 0
 
+mkHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
+         -> FilePath
+         -> HandleType
+         -> Bool                     -- buffered?
+         -> Maybe TextEncoding
+         -> NewlineMode
+         -> Maybe HandleFinalizer
+         -> Maybe (MVar Handle__)
+         -> IO Handle
+mkHandle dev filepath ha_type buffered mb_codec nl mb_finalizer other_side = do
+  mv <- mkHandleMVar dev filepath ha_type buffered mb_codec nl other_side
+  let handle = FileHandle filepath mv
+  case mb_finalizer of
+    Nothing -> pure ()
+    Just finalizer -> addHandleFinalizer handle finalizer
+  pure handle
+
+-- | makes a new 'Handle' without a finalizer.
+mkFileHandleNoFinalizer
+             :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev)
+             => dev -- ^ the underlying IO device, which must support
+                    -- 'IODevice', 'BufferedIO' and 'Typeable'
+             -> FilePath
+                    -- ^ a string describing the 'Handle', e.g. the file
+                    -- path for a file.  Used in error messages.
+             -> IOMode
+                    -- The mode in which the 'Handle' is to be used
+             -> Maybe TextEncoding
+                    -- Create the 'Handle' with no text encoding?
+             -> NewlineMode
+                    -- Translate newlines?
+             -> IO Handle
+mkFileHandleNoFinalizer dev filepath iomode mb_codec tr_newlines = do
+   mv <- mkHandleMVar dev filepath (ioModeToHandleType iomode) True{-buffered-}
+                      mb_codec
+                      tr_newlines
+                      Nothing{-other_side-}
+   pure (FileHandle filepath mv)
+
 -- | makes a new 'Handle'
 mkFileHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev)
              => dev -- ^ the underlying IO device, which must support
@@ -713,32 +757,42 @@ mkFileHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev)
              -> NewlineMode
                     -- Translate newlines?
              -> IO Handle
-mkFileHandle dev filepath iomode mb_codec tr_newlines =
-   mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec
-            tr_newlines
-            (Just handleFinalizer) Nothing{-other_side-}
+
+mkFileHandle dev filepath iomode mb_codec tr_newlines = do
+   h <- mkFileHandleNoFinalizer dev filepath iomode mb_codec tr_newlines
+   addHandleFinalizer h handleFinalizer
+   pure h
 
 -- | like 'mkFileHandle', except that a 'Handle' is created with two
 -- independent buffers, one for reading and one for writing.  Used for
 -- full-duplex streams, such as network sockets.
-mkDuplexHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
-               -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
-mkDuplexHandle dev filepath mb_codec tr_newlines = do
+mkDuplexHandleNoFinalizer ::
+  (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev)
+     => dev -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
+mkDuplexHandleNoFinalizer dev filepath mb_codec tr_newlines = do
 
-  write_side@(FileHandle _ write_m) <-
-       mkHandle dev filepath WriteHandle True mb_codec
+  write_m <-
+       mkHandleMVar dev filepath WriteHandle True mb_codec
                         tr_newlines
-                        (Just handleFinalizer)
-                        Nothing -- no othersie
+                        Nothing -- no other side
 
-  read_side@(FileHandle _ read_m) <-
-      mkHandle dev filepath ReadHandle True mb_codec
+  read_m <-
+      mkHandleMVar dev filepath ReadHandle True mb_codec
                         tr_newlines
-                        Nothing -- no finalizer
                         (Just write_m)
 
   return (DuplexHandle filepath read_m write_m)
 
+-- | like 'mkFileHandle', except that a 'Handle' is created with two
+-- independent buffers, one for reading and one for writing.  Used for
+-- full-duplex streams, such as network sockets.
+mkDuplexHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
+               -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
+mkDuplexHandle dev filepath mb_codec tr_newlines = do
+  handle <- mkDuplexHandleNoFinalizer dev filepath mb_codec tr_newlines
+  addHandleFinalizer handle handleFinalizer
+  pure handle
+
 ioModeToHandleType :: IOMode -> HandleType
 ioModeToHandleType ReadMode      = ReadHandle
 ioModeToHandleType WriteMode     = WriteHandle
@@ -775,7 +829,30 @@ closeTextCodecs Handle__{..} = do
   case haEncoder of Nothing -> return (); Just d -> Encoding.close d
 
 -- ---------------------------------------------------------------------------
--- closing Handles
+-- Closing a handle
+
+-- | This function exists temporarily to avoid an unused import warning in
+-- `bytestring`.
+hClose_impl :: Handle -> IO ()
+hClose_impl h@(FileHandle _ m)     = do
+  mb_exc <- hClose' h m
+  hClose_maybethrow mb_exc h
+hClose_impl h@(DuplexHandle _ r w) = do
+  excs <- mapM (hClose' h) [r,w]
+  hClose_maybethrow (listToMaybe (catMaybes excs)) h
+
+hClose_maybethrow :: Maybe SomeException -> Handle -> IO ()
+hClose_maybethrow Nothing  h = return ()
+hClose_maybethrow (Just e) h = hClose_rethrow e h
+
+hClose_rethrow :: SomeException -> Handle -> IO ()
+hClose_rethrow e h =
+  case fromException e of
+    Just ioe -> ioError (augmentIOError ioe "hClose" h)
+    Nothing  -> throwIO e
+
+hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
+hClose' h m = withHandle' "hClose" h m $ hClose_help
 
 -- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when
 -- EOF is read or an IO error occurs on a lazy stream.  The
diff --git a/libraries/base/GHC/IO/StdHandles.hs b/libraries/base/GHC/IO/StdHandles.hs
index 7768c1535c..cdb7d0eb47 100644
--- a/libraries/base/GHC/IO/StdHandles.hs
+++ b/libraries/base/GHC/IO/StdHandles.hs
@@ -20,7 +20,8 @@
 module GHC.IO.StdHandles
   ( -- std handles
     stdin, stdout, stderr,
-    openFile, openBinaryFile, openFileBlocking
+    openFile, openBinaryFile, openFileBlocking,
+    withFile, withBinaryFile, withFileBlocking
   ) where
 
 import GHC.IO
@@ -31,6 +32,7 @@ import qualified GHC.IO.Handle.FD as POSIX
 #if defined(mingw32_HOST_OS)
 import GHC.IO.SubSystem
 import qualified GHC.IO.Handle.Windows as Win
+import GHC.IO.Handle.Internals (hClose_impl)
 
 stdin :: Handle
 stdin = POSIX.stdin <!> Win.stdin
@@ -44,12 +46,28 @@ stderr = POSIX.stderr <!> Win.stderr
 openFile :: FilePath -> IOMode -> IO Handle
 openFile = POSIX.openFile <!> Win.openFile
 
+-- TODO: implement as for POSIX
+withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withFile = POSIX.withFile <!> wf
+  where
+    wf path mode act = bracket (Win.openFile path mode) hClose_impl act
+
 openBinaryFile :: FilePath -> IOMode -> IO Handle
 openBinaryFile = POSIX.openBinaryFile <!> Win.openBinaryFile
 
+withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withBinaryFile = POSIX.withBinaryFile <!> wf
+  where
+    wf path mode act = bracket (Win.openBinaryFile path mode) hClose_impl act
+
 openFileBlocking :: FilePath -> IOMode -> IO Handle
 openFileBlocking = POSIX.openFileBlocking <!> Win.openFileBlocking
 
+withFileBlocking :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withFileBlocking = POSIX.withFileBlocking <!> wf
+  where
+    wf path mode act = bracket (Win.openFileBlocking path mode) hClose_impl act
+
 #else
 
 stdin :: Handle
@@ -64,10 +82,19 @@ stderr = POSIX.stderr
 openFile :: FilePath -> IOMode -> IO Handle
 openFile = POSIX.openFile
 
+withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withFile = POSIX.withFile
+
 openBinaryFile :: FilePath -> IOMode -> IO Handle
 openBinaryFile = POSIX.openBinaryFile
 
+withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withBinaryFile = POSIX.withBinaryFile
+
 openFileBlocking :: FilePath -> IOMode -> IO Handle
 openFileBlocking = POSIX.openFileBlocking
 
+withFileBlocking :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withFileBlocking = POSIX.withFileBlocking
+
 #endif
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
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 06633d9b07..cc0100e585 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -25,6 +25,11 @@
     `newAlignedPinnedByteArray#` actually always assumed this but we didn't
     document this fact in the user facing API until now.
 
+    `Generic1`, and `Data` instances for `GHC.Tuple.Solo`.
+
+  * Under POSIX, `System.IO.openFile` will no longer leak a file descriptor if it
+    is interrupted by an asynchronous exception (#19114, #19115).
+
 ## 4.15.0.0 *TBA*
 
   * `openFile` now calls the `open` system call with an `interruptible` FFI