async exception safety for openFd
Audited for openFile and openFd, and this fixes all the ones I found where an async exception could prevent the file getting closed. Except for the lock pool, which is a whole other can of worms.
This commit is contained in:
parent
1dd770b1af
commit
0210e81d83
5 changed files with 35 additions and 13 deletions
|
@ -230,7 +230,7 @@ probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do
|
||||||
where
|
where
|
||||||
go f mode = do
|
go f mode = do
|
||||||
nukeFile f
|
nukeFile f
|
||||||
let locktest =
|
let locktest = mask $ const $
|
||||||
Posix.lockExclusive (Just mode) f
|
Posix.lockExclusive (Just mode) f
|
||||||
>>= Posix.dropLock
|
>>= Posix.dropLock
|
||||||
ok <- isRight <$> tryNonAsync locktest
|
ok <- isRight <$> tryNonAsync locktest
|
||||||
|
|
|
@ -94,4 +94,5 @@ tryPidLock m f posixlock = debugLocks $ liftIO . go =<< pidLockFile
|
||||||
-- avoid complicating any code that might expect to be able to see that
|
-- avoid complicating any code that might expect to be able to see that
|
||||||
-- lock file. But, it's not locked.
|
-- lock file. But, it's not locked.
|
||||||
dummyPosixLock :: Maybe FileMode -> LockFile -> IO ()
|
dummyPosixLock :: Maybe FileMode -> LockFile -> IO ()
|
||||||
dummyPosixLock m f = closeFd =<< openLockFile ReadLock m f
|
dummyPosixLock m f = mask $ const $
|
||||||
|
closeFd =<< openLockFile ReadLock m f
|
||||||
|
|
|
@ -174,12 +174,13 @@ linkToLock (Just _) src dest = do
|
||||||
, return False
|
, return False
|
||||||
)
|
)
|
||||||
Left _ -> catchBoolIO $ do
|
Left _ -> catchBoolIO $ do
|
||||||
fd <- openFd dest WriteOnly
|
let setup = do
|
||||||
(Just $ combineModes readModes)
|
fd <- openFd dest WriteOnly
|
||||||
(defaultFileFlags {exclusive = True})
|
(Just $ combineModes readModes)
|
||||||
h <- fdToHandle fd
|
(defaultFileFlags {exclusive = True})
|
||||||
readFile src >>= hPutStr h
|
fdToHandle fd
|
||||||
hClose h
|
let cleanup = hClose
|
||||||
|
bracket setup cleanup (\h -> readFile src >>= hPutStr h)
|
||||||
return True
|
return True
|
||||||
where
|
where
|
||||||
checklinked = do
|
checklinked = do
|
||||||
|
|
|
@ -58,7 +58,7 @@ lock lockreq mode lockfile = do
|
||||||
|
|
||||||
-- Tries to take an lock, but does not block.
|
-- Tries to take an lock, but does not block.
|
||||||
tryLock :: LockRequest -> Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
|
tryLock :: LockRequest -> Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
|
||||||
tryLock lockreq mode lockfile = do
|
tryLock lockreq mode lockfile = mask $ const $ do
|
||||||
l <- openLockFile lockreq mode lockfile
|
l <- openLockFile lockreq mode lockfile
|
||||||
v <- tryIO $ setLock l (lockreq, AbsoluteSeek, 0, 0)
|
v <- tryIO $ setLock l (lockreq, AbsoluteSeek, 0, 0)
|
||||||
case v of
|
case v of
|
||||||
|
@ -92,14 +92,17 @@ getLockStatus lockfile = do
|
||||||
Just (Just pid) -> StatusLockedBy pid
|
Just (Just pid) -> StatusLockedBy pid
|
||||||
|
|
||||||
getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID))
|
getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID))
|
||||||
getLockStatus' lockfile = go =<< catchMaybeIO open
|
getLockStatus' lockfile = bracket open close go
|
||||||
where
|
where
|
||||||
open = openLockFile ReadLock Nothing lockfile
|
open = catchMaybeIO $ openLockFile ReadLock Nothing lockfile
|
||||||
go Nothing = return Nothing
|
|
||||||
|
close (Just h) = closeFd h
|
||||||
|
close Nothing = return ()
|
||||||
|
|
||||||
go (Just h) = do
|
go (Just h) = do
|
||||||
v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
|
v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
|
||||||
closeFd h
|
|
||||||
return (Just (fmap fst v))
|
return (Just (fmap fst v))
|
||||||
|
go Nothing = return Nothing
|
||||||
|
|
||||||
dropLock :: LockHandle -> IO ()
|
dropLock :: LockHandle -> IO ()
|
||||||
dropLock (LockHandle fd) = closeFd fd
|
dropLock (LockHandle fd) = closeFd fd
|
||||||
|
|
|
@ -0,0 +1,17 @@
|
||||||
|
[[!comment format=mdwn
|
||||||
|
username="joey"
|
||||||
|
subject="""comment 15"""
|
||||||
|
date="2020-06-05T19:00:07Z"
|
||||||
|
content="""
|
||||||
|
Some progress: All threads that `async` or `forkOS` starts are now
|
||||||
|
confirmed to get shut down when an async exception reaches the code that
|
||||||
|
uses them. All uses of SomeException are confirmed to not catch async
|
||||||
|
exceptions. All file opening is confirmed to bracket and close (except for
|
||||||
|
the lock pool).
|
||||||
|
|
||||||
|
Still to do:
|
||||||
|
|
||||||
|
* process things noted in comment #13
|
||||||
|
* data structures that get modified while an action is running and need
|
||||||
|
to be cleaned up on an async exception (eg the lock pool)
|
||||||
|
"""]]
|
Loading…
Add table
Add a link
Reference in a new issue