summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-12-08 17:03:39 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-12-08 17:03:39 -0400
commite2dd3ae351cbe7b2b1a027ef257808dde02d899f (patch)
treeb8bf1c308dc9ea3fbc80db47921a2b3eb6c5a89b
parent0c7ac5732d8bece6ba259bfa31e383612f3fb8df (diff)
Got object sending working in direct mode.
However, I don't yet have a reliable way to deal with files being modified while they're being transferred. I have code that detects it on the sending side, but the receiver is still free to move the wrong content into its annex, and record that it has the content. So that's not acceptable, and I'll need to work on it some more. However, at this point I can use a direct mode repository as a remote and transfer files from and to it.
-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