summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex/Content.hs71
-rw-r--r--Annex/Content/Direct.hs28
-rw-r--r--Command/SendKey.hs5
-rw-r--r--Remote/Git.hs20
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