diff options
Diffstat (limited to 'Annex')
| -rw-r--r-- | Annex/Content.hs | 71 | ||||
| -rw-r--r-- | Annex/Content/Direct.hs | 28 |
2 files changed, 73 insertions, 26 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index f0b9b4957..61f521bd1 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -16,6 +16,7 @@ module Annex.Content ( withTmp, checkDiskSpace, moveAnnex, + sendAnnex, removeAnnex, fromAnnex, moveBad, @@ -50,23 +51,6 @@ import Git.SharedRepository import Annex.Perms import Annex.Content.Direct -{- 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) - {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool inAnnex = inAnnex' id False $ liftIO . doesFileExist @@ -87,7 +71,7 @@ inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect checkdirect (loc:locs) = do r <- check loc if isgood r - then ifM (unmodifed key loc) + then ifM (goodContent key loc) ( return r , checkdirect locs ) @@ -283,6 +267,57 @@ replaceFile file a = do _ -> 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) + + cleanObjectLoc :: Key -> Annex () cleanObjectLoc key = do file <- inRepo $ gitAnnexLocation key diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs index 7ab70e612..4a91cfcf6 100644 --- a/Annex/Content/Direct.hs +++ b/Annex/Content/Direct.hs @@ -7,8 +7,10 @@ module Annex.Content.Direct ( associatedFiles, - unmodifed, + goodContent, updateCache, + recordedCache, + compareCache, removeCache ) where @@ -38,16 +40,26 @@ associatedFiles key = do - expensive checksum, this relies on a cache that contains the file's - expected mtime and inode. -} -unmodifed :: Key -> FilePath -> Annex Bool -unmodifed key file = withCacheFile key $ \cachefile -> do - curr <- getCache file - old <- catchDefaultIO Nothing $ readCache <$> readFile cachefile +goodContent :: Key -> FilePath -> Annex Bool +goodContent key file = do + old <- recordedCache key + compareCache file old + +{- Gets the recorded cache for a key. -} +recordedCache :: Key -> Annex (Maybe Cache) +recordedCache key = withCacheFile key $ \cachefile -> + catchDefaultIO Nothing $ readCache <$> readFile cachefile + +{- Compares a cache with the current cache for a file. -} +compareCache :: FilePath -> Maybe Cache -> Annex Bool +compareCache file old = do + curr <- liftIO $ genCache file return $ isJust curr && curr == old {- Stores a cache of attributes for a file that is associated with a key. -} updateCache :: Key -> FilePath -> Annex () updateCache key file = withCacheFile key $ \cachefile -> - maybe noop (writeFile cachefile . showCache) =<< getCache file + maybe noop (writeFile cachefile . showCache) =<< genCache file {- Removes a cache. -} removeCache :: Key -> Annex () @@ -76,8 +88,8 @@ readCache s = case words s of <*> readish mtime _ -> Nothing -getCache :: FilePath -> IO (Maybe Cache) -getCache f = catchDefaultIO Nothing $ toCache <$> getFileStatus f +genCache :: FilePath -> IO (Maybe Cache) +genCache f = catchDefaultIO Nothing $ toCache <$> getFileStatus f toCache :: FileStatus -> Maybe Cache toCache s |