diff options
| -rw-r--r-- | docs/users_guide/9.2.1-notes.rst | 3 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/FD.hs | 135 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle.hs | 26 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/FD.hs | 122 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Internals.hs | 143 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/StdHandles.hs | 29 | ||||
| -rw-r--r-- | libraries/base/System/IO.hs | 19 | ||||
| -rw-r--r-- | libraries/base/System/Posix/Internals.hs | 68 | ||||
| -rw-r--r-- | libraries/base/changelog.md | 5 |
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 |