summaryrefslogtreecommitdiff
path: root/Utility/LockFile
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-11-13 15:43:09 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-11-13 15:43:09 -0400
commit2f9fcff61101e0e696aa30ab79e0594b2ac32a0f (patch)
tree1e5bc66d43a9a365bb5b99d5d35eaeba269a600e /Utility/LockFile
parent664ed6564ad4ac84b9e04c3899c167cc5fe9edcb (diff)
fixed a fd double-close
Diffstat (limited to 'Utility/LockFile')
-rw-r--r--Utility/LockFile/PidLock.hs47
1 files changed, 20 insertions, 27 deletions
diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index d2bd31c36..68d9b7bac 100644
--- a/Utility/LockFile/PidLock.hs
+++ b/Utility/LockFile/PidLock.hs
@@ -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'