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.

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