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:
parent
1aba23ab4e
commit
b0155d9093
1 changed files with 24 additions and 12 deletions
|
@ -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
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue