diff options
-rw-r--r-- | Annex/Content.hs | 32 | ||||
-rw-r--r-- | Annex/Ssh.hs | 11 | ||||
-rw-r--r-- | Remote/Helper/Hooks.hs | 10 | ||||
-rw-r--r-- | Utility/LockFile/Posix.hs | 54 |
4 files changed, 68 insertions, 39 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index b3c62ee0a..90ab7db58 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -101,23 +101,21 @@ inAnnexSafe key = inAnnex' (fromMaybe False) (Just False) go key =<< contentLockFile key #ifndef mingw32_HOST_OS - checkindirect f = liftIO $ openExistingLockFile f >>= check is_missing + checkindirect contentfile = liftIO $ checkOr is_missing contentfile {- In direct mode, the content file must exist, but - - the lock file often generally won't exist unless a removal is in - - process. This does not create the lock file, it only checks for - - it. -} + - the lock file generally won't exist unless a removal is in + - process. -} checkdirect contentfile lockfile = liftIO $ ifM (doesFileExist contentfile) - ( openExistingLockFile lockfile >>= check is_unlocked + ( checkOr is_unlocked lockfile , return is_missing ) - check _ (Just h) = do - v <- getLock h (ReadLock, AbsoluteSeek, 0, 0) - closeFd h + checkOr def lockfile = do + v <- checkLocked lockfile return $ case v of - Just _ -> is_locked - Nothing -> is_unlocked - check def Nothing = return def + Nothing -> def + Just True -> is_locked + Just False -> is_unlocked #else checkindirect f = liftIO $ ifM (doesFileExist f) ( do @@ -161,7 +159,7 @@ lockContent key a = do contentfile <- calcRepo $ gitAnnexLocation key lockfile <- contentLockFile key maybe noop setuplockfile lockfile - bracket (liftIO $ lock contentfile lockfile) (unlock lockfile) (const a) + bracket (lock contentfile lockfile) (unlock lockfile) (const a) where alreadylocked = error "content is locked" setuplockfile lockfile = modifyContent lockfile $ @@ -171,8 +169,11 @@ lockContent key a = do void $ liftIO $ tryIO $ nukeFile lockfile #ifndef mingw32_HOST_OS - lock contentfile Nothing = opencontentforlock contentfile >>= dolock - lock _ (Just lockfile) = createLockFile Nothing lockfile >>= dolock . Just + lock contentfile Nothing = liftIO $ + opencontentforlock contentfile >>= dolock + lock _ (Just lockfile) = do + mode <- annexFileMode + liftIO $ createLockFile mode lockfile >>= dolock . Just {- Since content files are stored with the write bit disabled, have - to fiddle with permissions to open for an exclusive lock. -} opencontentforlock f = catchDefaultIO Nothing $ @@ -189,7 +190,8 @@ lockContent key a = do maybe noop cleanuplockfile mlockfile liftIO $ maybe noop closeFd mfd #else - lock _ (Just lockfile) = maybe alreadylocked (return . Just) =<< lockExclusive lockfile + lock _ (Just lockfile) = liftIO $ + maybe alreadylocked (return . Just) =<< lockExclusive lockfile lock _ Nothing = return Nothing unlock mlockfile mlockhandle = do liftIO $ maybe noop dropLock mlockhandle diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 2b1b809ff..ad636b4aa 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -152,13 +152,12 @@ sshCleanup = mapM_ cleanup =<< enumSocketFiles let lockfile = socket2lock socketfile unlockFile lockfile mode <- annexFileMode - fd <- liftIO $ noUmask mode $ createLockFile (Just mode) lockfile - v <- liftIO $ tryIO $ - setLock fd (WriteLock, AbsoluteSeek, 0, 0) + v <- liftIO $ noUmask mode $ tryLockExclusive (Just mode) lockfile case v of - Left _ -> noop - Right _ -> forceStopSsh socketfile - liftIO $ closeFd fd + Nothing -> noop + Just lck -> do + forceStopSsh socketfile + liftIO $ dropLock lck #else forceStopSsh socketfile #endif diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index 96f73cce3..529c35d3f 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -83,18 +83,12 @@ runHooks r starthook stophook a = do unlockFile lck #ifndef mingw32_HOST_OS mode <- annexFileMode - fd <- liftIO $ noUmask mode $ createLockFile (Just mode) lck - v <- liftIO $ tryIO $ - setLock fd (WriteLock, AbsoluteSeek, 0, 0) - case v of - Left _ -> noop - Right _ -> run stophook - liftIO $ closeFd fd + v <- liftIO $ noUmask mode $ tryLockExclusive (Just mode) lck #else v <- liftIO $ lockExclusive lck +#endif case v of Nothing -> noop Just lockhandle -> do run stophook liftIO $ dropLock lockhandle -#endif diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs index b49c5f173..1e43a2832 100644 --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -9,15 +9,21 @@ module Utility.LockFile.Posix ( LockHandle, lockShared, lockExclusive, - dropLock, + tryLockExclusive, createLockFile, openExistingLockFile, + isLocked, + checkLocked, + dropLock, ) where import Utility.Exception +import Utility.Applicative import System.IO import System.Posix +import Data.Maybe +import Control.Applicative type LockFile = FilePath @@ -31,27 +37,55 @@ lockShared = lock ReadLock lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle lockExclusive = lock WriteLock --- The FileMode is used when creating a new lock file. +-- Tries to take an exclusive lock, but does not block. +tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) +tryLockExclusive mode lockfile = do + l <- openLockFile mode lockfile + v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0) + case v of + Left _ -> do + closeFd l + return Nothing + Right _ -> return $ Just $ LockHandle l + +-- Setting the FileMode allows creation of a new lock file. +-- If it's Nothing then this only succeeds when the lock file already exists. lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle lock lockreq mode lockfile = do - l <- createLockFile mode lockfile + l <- openLockFile mode lockfile waitToSetLock l (lockreq, AbsoluteSeek, 0, 0) return (LockHandle l) -- Create and opens lock file; does not lock it. -createLockFile :: Maybe FileMode -> LockFile -> IO Fd -createLockFile = openLockFile ReadWrite +createLockFile :: FileMode -> LockFile -> IO Fd +createLockFile filemode = openLockFile (Just filemode) --- Opens an existing lock file; does not lock it or create it. +-- Opens an existing lock file; does not lock it, and if it does not exist, +-- returns Nothing. openExistingLockFile :: LockFile -> IO (Maybe Fd) -openExistingLockFile = catchMaybeIO . openLockFile ReadOnly Nothing +openExistingLockFile = catchMaybeIO . openLockFile Nothing -- Close on exec flag is set so child processes do not inherit the lock. -openLockFile :: OpenMode -> Maybe FileMode -> LockFile -> IO Fd -openLockFile openmode filemode lockfile = do - l <- openFd lockfile openmode filemode defaultFileFlags +openLockFile :: Maybe FileMode -> LockFile -> IO Fd +openLockFile filemode lockfile = do + l <- openFd lockfile ReadWrite filemode defaultFileFlags setFdOption l CloseOnExec True return l +-- Check if a file is locked, either exclusively, or with shared lock. +-- When the file doesn't exist, it's considered not locked. +isLocked :: LockFile -> IO Bool +isLocked = fromMaybe False <$$> checkLocked + +checkLocked :: LockFile -> IO (Maybe Bool) +checkLocked lockfile = go =<< catchMaybeIO open + where + open = openFd lockfile ReadOnly Nothing defaultFileFlags + go Nothing = return Nothing + go (Just h) = do + ret <- isJust <$> getLock h (ReadLock, AbsoluteSeek, 0, 0) + closeFd h + return $ Just ret + dropLock :: LockHandle -> IO () dropLock (LockHandle fd) = closeFd fd |