diff options
author | Joey Hess <joey@kitenet.net> | 2011-11-09 21:45:03 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2011-11-09 21:54:42 -0400 |
commit | cf0174c922e4a4f473a846ec0488ea4011ab500c (patch) | |
tree | 5c000d6a4327e5f8f473a5cca6e46aa17a8fa59a /Annex | |
parent | 737f043c55b13bf8dbd6887d3e78d32d13a8682a (diff) |
content locking
I've tested that this solves the cyclic drop problem.
Have not looked at cyclic move, etc.
Diffstat (limited to 'Annex')
-rw-r--r-- | Annex/Content.hs | 52 |
1 files changed, 39 insertions, 13 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index efe12bb5d..65dbe43f6 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -23,6 +23,9 @@ module Annex.Content ( saveState ) where +import Control.Exception (bracket_) +import System.Posix.Types + import Common.Annex import Logs.Location import Annex.UUID @@ -35,6 +38,7 @@ import Utility.FileMode import Types.Key import Utility.DataUnits import Config +import Annex.Exception {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool @@ -48,22 +52,44 @@ inAnnex' a key = do {- A safer check; the key's content must not only be present, but - is not in the process of being removed. -} inAnnexSafe :: Key -> Annex (Maybe Bool) -inAnnexSafe = inAnnex' $ \f -> do - e <- doesFileExist f - if e - then do - locked <- testlock f - if locked - then return Nothing - else return $ Just True - else return $ Just False +inAnnexSafe = inAnnex' $ \f -> openForLock f False >>= check where - testlock f = return False -- TODO + check Nothing = return is_missing + check (Just h) = do + v <- getLock h (ReadLock, AbsoluteSeek, 0, 0) + closeFd h + return $ case v of + Just _ -> is_locked + Nothing -> is_unlocked + is_locked = Nothing + is_unlocked = Just True + is_missing = Just False -{- Content is exclusively locked to indicate that it's in the process of - - being removed. -} +{- Content is exclusively locked to indicate that it's in the process + - of being removed. (If the content is not present, no locking is done.) -} lockContent :: Key -> Annex a -> Annex a -lockContent key a = a -- TODO +lockContent key a = do + file <- fromRepo $ gitAnnexLocation key + bracketIO (openForLock file True >>= lock) unlock a + where + lock Nothing = return Nothing + lock (Just l) = do + setLock l (WriteLock, AbsoluteSeek, 0, 0) + return $ Just l + unlock Nothing = return () + unlock (Just l) = closeFd l + +openForLock :: FilePath -> Bool -> IO (Maybe Fd) +openForLock file writelock = bracket_ prep cleanup $ + catch (Just <$> openFd file mode Nothing defaultFileFlags) + (const $ return Nothing) + where + mode = if writelock then ReadWrite else ReadOnly + -- Since files are stored with the write bit disabled, + -- have to fiddle with permissions to open for an + -- exclusive lock. + prep = when writelock $ allowWrite file + cleanup = when writelock $ preventWrite file {- Calculates the relative path to use to link a file to a key. -} calcGitLink :: FilePath -> Key -> Annex FilePath |