Commit 3547a124 authored by Kamil's avatar Kamil
Browse files

Make openFile more tolerant of async excs (#18832)

parent 0cf23263
Pipeline #44560 passed with stages
in 212 minutes and 11 seconds
......@@ -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.
:: 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 `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
......@@ -84,6 +84,9 @@
call, ensuring that the call can be interrupted with `SIGINT` on POSIX
* 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`.
{-# 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
No failures observed - success
......@@ -150,3 +150,4 @@ test('T17414',
test('T17510', expect_broken(17510), compile_and_run, [''])
test('bytestringread001', extra_run_opts(''), 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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment