also compare lock file contents to double-check link worked

And it closes the tmp file before this. I don't know if this will help
avoid lustre's craziness, but it can't hurt..
This commit is contained in:
Joey Hess 2015-11-13 15:20:52 -04:00
parent 1aba23ab4e
commit b0155d9093
Failed to extract signature

View file

@ -99,17 +99,18 @@ tryLock lockfile = trySideLock lockfile $ \sidelock -> do
(tmp, h) <- openTempFile (takeDirectory lockfile) "locktmp" (tmp, h) <- openTempFile (takeDirectory lockfile) "locktmp"
setFileMode tmp (combineModes readModes) setFileMode tmp (combineModes readModes)
hPutStr h . show =<< mkPidLock hPutStr h . show =<< mkPidLock
fd <- handleToFd h hClose h
let failedlock = do let failedlock = do
closeFd fd
nukeFile tmp nukeFile tmp
maybe noop Posix.dropLock sidelock
return Nothing return Nothing
let tooklock = return $ Just $ LockHandle lockfile fd sidelock let tooklock fd = return $ Just $ LockHandle lockfile fd sidelock
ifM (linkToLock sidelock tmp lockfile) mfd <- linkToLock sidelock tmp lockfile
( do case mfd of
Just fd -> do
nukeFile tmp nukeFile tmp
tooklock tooklock fd
, do Nothing -> do
v <- readPidLock lockfile v <- readPidLock lockfile
hn <- getHostName hn <- getHostName
case v of case v of
@ -120,9 +121,9 @@ tryLock lockfile = trySideLock lockfile $ \sidelock -> do
-- we know that the pidlock is -- we know that the pidlock is
-- stale, and can take it over. -- stale, and can take it over.
rename tmp lockfile rename tmp lockfile
tooklock fd <- openFd lockfile ReadOnly Nothing defaultFileFlags
tooklock fd
_ -> failedlock _ -> failedlock
)
-- Linux's open(2) man page recommends linking a pid lock into place, -- Linux's open(2) man page recommends linking a pid lock into place,
-- as the most portable atomic operation that will fail if -- as the most portable atomic operation that will fail if
@ -140,11 +141,22 @@ tryLock lockfile = trySideLock lockfile $ \sidelock -> do
-- can't do anything about such a lying filesystem. -- can't do anything about such a lying filesystem.
-- At least the side lock file will prevent git-annex's running on the same -- 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. -- host from running concurrently even on such a lying filesystem.
linkToLock :: SideLockHandle -> FilePath -> FilePath -> IO Bool linkToLock :: SideLockHandle -> FilePath -> FilePath -> IO (Maybe Fd)
linkToLock Nothing _ _ = return False linkToLock Nothing _ _ = return Nothing
linkToLock (Just _) src dest = do linkToLock (Just _) src dest = do
_ <- tryIO $ createLink src dest _ <- tryIO $ createLink src dest
catchDefaultIO False checklink ifM (catchDefaultIO False checklink)
( catchDefaultIO Nothing $ 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
)
where where
checklink = do checklink = do
x <- getSymbolicLinkStatus src x <- getSymbolicLinkStatus src