diff options
| -rw-r--r-- | Annex/Content.hs | 71 | ||||
| -rw-r--r-- | Annex/Content/Direct.hs | 28 | ||||
| -rw-r--r-- | Command/SendKey.hs | 5 | ||||
| -rw-r--r-- | Remote/Git.hs | 20 |
4 files changed, 85 insertions, 39 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 diff --git a/Command/SendKey.hs b/Command/SendKey.hs index ccbfa9030..82c159f66 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -23,9 +23,8 @@ seek = [withKeys start] start :: Key -> CommandStart start key = ifM (inAnnex key) - ( fieldTransfer Upload key $ \_p -> do - file <- inRepo $ gitAnnexLocation key - liftIO $ rsyncServerSend file + ( fieldTransfer Upload key $ \_p -> + sendAnnex key $ liftIO . rsyncServerSend , do warning "requested key is not present" liftIO exitFailure diff --git a/Remote/Git.hs b/Remote/Git.hs index 0933a1cae..a333a707b 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -262,9 +262,9 @@ copyFromRemote r key file dest -- run copy from perspective of remote liftIO $ onLocal r $ do ensureInitialized - loc <- inRepo $ gitAnnexLocation key - upload u key file noRetry $ - rsyncOrCopyFile params loc dest + Annex.Content.sendAnnex key $ \object -> + upload u key file noRetry $ + rsyncOrCopyFile params object dest | Git.repoIsSsh r = feedprogressback $ \feeder -> rsyncHelper (Just feeder) =<< rsyncParamsRemote r True key dest file @@ -324,8 +324,12 @@ copyFromRemoteCheap r key file {- Tries to copy a key's content to a remote's annex. -} copyToRemote :: Git.Repo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool copyToRemote r key file p - | not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ do - keysrc <- inRepo $ gitAnnexLocation key + | not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ copylocal + | Git.repoIsSsh r = commitOnCleanup r $ Annex.Content.sendAnnex key $ \object -> + rsyncHelper (Just p) =<< rsyncParamsRemote r False key object file + | otherwise = error "copying to non-ssh repo not supported" + where + copylocal = Annex.Content.sendAnnex key $ \object -> do params <- rsyncParams r u <- getUUID -- run copy from perspective of remote @@ -336,12 +340,8 @@ copyToRemote r key file p download u key file noRetry $ Annex.Content.saveState True `after` Annex.Content.getViaTmp key - (\d -> rsyncOrCopyFile params keysrc d p) + (\d -> rsyncOrCopyFile params object d p) ) - | Git.repoIsSsh r = commitOnCleanup r $ do - keysrc <- inRepo $ gitAnnexLocation key - rsyncHelper (Just p) =<< rsyncParamsRemote r False key keysrc file - | otherwise = error "copying to non-ssh repo not supported" rsyncHelper :: Maybe MeterUpdate -> [CommandParam] -> Annex Bool rsyncHelper callback params = do |