fixed a fd double-close

This commit is contained in:
Joey Hess 2015-11-13 15:43:09 -04:00
parent b0155d9093
commit 389c6c7d37
Failed to extract signature

View file

@ -39,7 +39,7 @@ import System.Directory
type LockFile = FilePath
data LockHandle = LockHandle FilePath Fd SideLockHandle
data LockHandle = LockHandle FilePath FileStatus SideLockHandle
type SideLockHandle = Maybe Posix.LockHandle
@ -100,17 +100,17 @@ tryLock lockfile = trySideLock lockfile $ \sidelock -> do
setFileMode tmp (combineModes readModes)
hPutStr h . show =<< mkPidLock
hClose h
st <- getFileStatus tmp
let failedlock = do
nukeFile tmp
maybe noop Posix.dropLock sidelock
return Nothing
let tooklock fd = return $ Just $ LockHandle lockfile fd sidelock
mfd <- linkToLock sidelock tmp lockfile
case mfd of
Just fd -> do
let tooklock = return $ Just $ LockHandle lockfile st sidelock
ifM (linkToLock sidelock tmp lockfile)
( do
nukeFile tmp
tooklock fd
Nothing -> do
tooklock
, do
v <- readPidLock lockfile
hn <- getHostName
case v of
@ -121,9 +121,9 @@ tryLock lockfile = trySideLock lockfile $ \sidelock -> do
-- we know that the pidlock is
-- stale, and can take it over.
rename tmp lockfile
fd <- openFd lockfile ReadOnly Nothing defaultFileFlags
tooklock fd
tooklock
_ -> failedlock
)
-- Linux's open(2) man page recommends linking a pid lock into place,
-- as the most portable atomic operation that will fail if
@ -141,21 +141,16 @@ tryLock lockfile = trySideLock lockfile $ \sidelock -> do
-- can't do anything about such a lying filesystem.
-- At least the side lock file will prevent git-annex's running on the same
-- host from running concurrently even on such a lying filesystem.
linkToLock :: SideLockHandle -> FilePath -> FilePath -> IO (Maybe Fd)
linkToLock Nothing _ _ = return Nothing
linkToLock :: SideLockHandle -> FilePath -> FilePath -> IO Bool
linkToLock Nothing _ _ = return False
linkToLock (Just _) src dest = do
_ <- tryIO $ createLink src dest
ifM (catchDefaultIO False checklink)
( catchDefaultIO Nothing $ do
ifM (catchBoolIO checklink)
( catchBoolIO $ do
srccontent <- readFile src
h <- openFile dest ReadMode
destcontent <- hGetContents h
if srccontent /= destcontent
then do
hClose h
return Nothing
else Just <$> handleToFd h
, return Nothing
destcontent <- readFile dest
return (srccontent == destcontent)
, return False
)
where
checklink = do
@ -192,13 +187,12 @@ waitLock (Seconds timeout) lockfile = go timeout
error $ "Gave up waiting for possibly stale pid lock file " ++ lockfile
dropLock :: LockHandle -> IO ()
dropLock (LockHandle lockfile fd sidelock) = do
dropLock (LockHandle lockfile _ sidelock) = do
-- Drop side lock first, at which point the pid lock will be
-- considered stale.
-- The side lock file cannot be deleted because another process may
-- have it open and be waiting to lock it.
maybe noop Posix.dropLock sidelock
closeFd fd
nukeFile lockfile
getLockStatus :: LockFile -> IO LockStatus
@ -213,10 +207,9 @@ checkLocked lockfile = conv <$> getLockStatus lockfile
-- Checks that the lock file still exists, and is the same file that was
-- locked to get the LockHandle.
checkSaneLock :: LockFile -> LockHandle -> IO Bool
checkSaneLock lockfile (LockHandle _ fd _) =
checkSaneLock lockfile (LockHandle _ st _) =
go =<< catchMaybeIO (getFileStatus lockfile)
where
go Nothing = return False
go (Just st) = do
fdst <- getFdStatus fd
return $ deviceID fdst == deviceID st && fileID fdst == fileID st
go (Just st') = do
return $ deviceID st == deviceID st' && fileID st == fileID st'