diff options
Diffstat (limited to 'Annex/Content.hs')
| -rw-r--r-- | Annex/Content.hs | 181 |
1 files changed, 137 insertions, 44 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index 887729fee..5c902e8a9 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -1,6 +1,6 @@ {- git-annex file content managing - - - Copyright 2010 Joey Hess <joey@kitenet.net> + - Copyright 2010,2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,12 +10,12 @@ module Annex.Content ( inAnnexSafe, lockContent, calcGitLink, - logStatus, getViaTmp, getViaTmpUnchecked, withTmp, checkDiskSpace, moveAnnex, + sendAnnex, removeAnnex, fromAnnex, moveBad, @@ -32,7 +32,6 @@ import System.IO.Unsafe (unsafeInterleaveIO) import Common.Annex import Logs.Location -import Annex.UUID import qualified Git import qualified Git.Config import qualified Annex @@ -48,21 +47,40 @@ import Config import Annex.Exception import Git.SharedRepository import Annex.Perms +import Annex.Content.Direct {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool -inAnnex = inAnnex' doesFileExist -inAnnex' :: (FilePath -> IO a) -> Key -> Annex a -inAnnex' a key = do - whenM (fromRepo Git.repoIsUrl) $ - error "inAnnex cannot check remote repo" - inRepo $ \g -> gitAnnexLocation key g >>= a +inAnnex = inAnnex' id False $ liftIO . doesFileExist + +{- Generic inAnnex, handling both indirect and direct mode. + - + - In direct mode, at least one of the associated files must pass the + - check. Additionally, the file must be unmodified. + -} +inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a +inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect + where + checkindirect loc = do + whenM (fromRepo Git.repoIsUrl) $ + error "inAnnex cannot check remote repo" + check loc + checkdirect [] = return bad + checkdirect (loc:locs) = do + r <- check loc + if isgood r + then ifM (goodContent key loc) + ( return r + , checkdirect locs + ) + else checkdirect locs {- 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 -> openforlock f >>= check +inAnnexSafe = inAnnex' (maybe False id) (Just False) go where + go f = liftIO $ openforlock f >>= check openforlock f = catchMaybeIO $ openFd f ReadOnly Nothing defaultFileFlags check Nothing = return is_missing @@ -112,13 +130,6 @@ calcGitLink file key = do where whoops = error $ "unable to normalize " ++ file -{- Updates the Logs.Location when a key's presence changes in the current - - repository. -} -logStatus :: Key -> LogStatus -> Annex () -logStatus key status = do - u <- getUUID - logChange key u status - {- Runs an action, passing it a temporary filename to get, - and if the action succeeds, moves the temp file into - the annex as a key's content. -} @@ -151,10 +162,10 @@ prepTmp key = do - and not being copied into place. -} getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmpUnchecked key action = do - tmp <- prepTmp key - ifM (action tmp) + tmpfile <- prepTmp key + ifM (action tmpfile) ( do - moveAnnex key tmp + moveAnnex key tmpfile logStatus key InfoPresent return True , do @@ -194,7 +205,9 @@ checkDiskSpace destination key alreadythere = do " more" ++ forcemsg forcemsg = " (use --force to override this check or adjust annex.diskreserve)" -{- Moves a file into .git/annex/objects/ +{- Moves a key's content into .git/annex/objects/ + - + - In direct mode, moves it to the associated file, or files. - - What if the key there already has content? This could happen for - various reasons; perhaps the same content is being annexed again. @@ -216,22 +229,85 @@ checkDiskSpace destination key alreadythere = do - meet. -} moveAnnex :: Key -> FilePath -> Annex () -moveAnnex key src = do - dest <- inRepo $ gitAnnexLocation key - ifM (liftIO $ doesFileExist dest) - ( liftIO $ removeFile src - , do - createContentDir dest - liftIO $ moveFile src dest - freezeContent dest - freezeContentDir dest - ) +moveAnnex key src = withObjectLoc key storeobject storedirect + where + storeobject dest = do + ifM (liftIO $ doesFileExist dest) + ( liftIO $ removeFile src + , do + createContentDir dest + liftIO $ moveFile src dest + freezeContent dest + freezeContentDir dest + ) + storedirect [] = storeobject =<< inRepo (gitAnnexLocation key) + storedirect (dest:fs) = do + updateCache key src + thawContent src + liftIO $ replaceFile dest $ moveFile src + liftIO $ forM_ fs $ \f -> replaceFile f $ createLink dest + +{- Replaces any existing file with a new version, by running an action. + - First, makes sure the file is deleted. Or, if it didn't already exist, + - makes sure the parent directory exists. -} +replaceFile :: FilePath -> (FilePath -> IO ()) -> IO () +replaceFile file a = do + r <- tryIO $ removeFile file + case r of + Left _ -> createDirectoryIfMissing True (parentDir file) + _ -> noop + a file + +{- Runs an action to transfer an object's content. + - + - In direct mode, it's possible for the file to change as it's being sent. + - If this happens, returns False. Currently, an arbitrary amount of bad + - data may be sent when this occurs. The send is not retried even if + - another file is known to have the same content; the action may not be + - idempotent. + - + - Since objects changing as they're transferred is a somewhat unusual + - situation, and since preventing writes to the file would be expensive, + - annoying or both, we instead detect the situation after the affect, + - and fail. Thus, it's up to the caller to detect a failure and take + - appropriate action. Such as, for example, ensuring that the bad + - data that was sent does not get installed into the annex it's being + - sent to. + -} +sendAnnex :: Key -> (FilePath -> Annex Bool) -> Annex Bool +sendAnnex key a = withObjectLoc key sendobject senddirect + where + sendobject = a + senddirect [] = return False + senddirect (f:fs) = do + cache <- recordedCache key + -- check that we have a good file + ifM (compareCache f cache) + ( do + r <- sendobject f + -- see if file changed while it was being sent + ok <- compareCache f cache + return (r && ok) + , senddirect fs + ) + +{- Performs an action, passing it the location to use for a key's content. + - + - In direct mode, the associated files will be passed. But, if there are + - no associated files for a key, the indirect mode action will be + - performed instead. -} +withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a +withObjectLoc key indirect direct = ifM isDirect + ( do + fs <- associatedFiles key + if null fs + then goindirect + else direct fs + , goindirect + ) + where + goindirect = indirect =<< inRepo (gitAnnexLocation key) -withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a -withObjectLoc key a = do - file <- inRepo $ gitAnnexLocation key - let dir = parentDir file - a (dir, file) cleanObjectLoc :: Key -> Annex () cleanObjectLoc key = do @@ -244,18 +320,35 @@ cleanObjectLoc key = do maybe noop (const $ removeparents dir (n-1)) <=< catchMaybeIO $ removeDirectory dir -{- Removes a key's file from .git/annex/objects/ -} +{- Removes a key's file from .git/annex/objects/ + - + - In direct mode, deletes the associated files or files, and replaces + - them with symlinks. -} removeAnnex :: Key -> Annex () -removeAnnex key = withObjectLoc key $ \(dir, file) -> do - liftIO $ do - allowWrite dir - removeFile file - cleanObjectLoc key +removeAnnex key = withObjectLoc key remove removedirect + where + remove file = do + liftIO $ do + allowWrite $ parentDir file + removeFile file + cleanObjectLoc key + removedirect fs = do + removeCache key + mapM_ resetfile fs + resetfile f = do + l <- calcGitLink f key + top <- fromRepo Git.repoPath + cwd <- liftIO getCurrentDirectory + let top' = fromMaybe top $ absNormPath cwd top + let l' = relPathDirToFile top' (fromMaybe l $ absNormPath top' l) + liftIO $ replaceFile f $ const $ + createSymbolicLink l' f {- Moves a key's file out of .git/annex/objects/ -} fromAnnex :: Key -> FilePath -> Annex () -fromAnnex key dest = withObjectLoc key $ \(dir, file) -> do - liftIO $ allowWrite dir +fromAnnex key dest = do + file <- inRepo $ gitAnnexLocation key + liftIO $ allowWrite $ parentDir file thawContent file liftIO $ moveFile file dest cleanObjectLoc key |