fixed a fd double-close

diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index d2bd31c36a399764f26ce1d8a27ef8bd5d1a336e..68d9b7bac2ef50828777b82bae9dee5d60606a52 100644 (file)
--- 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'