Special remotes now all rollback storage of keys that get modified during the transfer, which can happen in direct mode.

Annex/Content.hs

@@ -262,21 +262,11 @@ replaceFile file a = do
 {- 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.
+ - If this happens, runs the rollback action and returns False. The
+ - rollback action should remove the data that was transferred for the key.
  -}
-sendAnnex :: Key -> (FilePath -> Annex Bool) -> Annex Bool
-sendAnnex key a = withObjectLoc key sendobject senddirect
+sendAnnex :: Key -> (Annex ()) -> (FilePath -> Annex Bool) -> Annex Bool
+sendAnnex key rollback a = withObjectLoc key sendobject senddirect
   where
 	sendobject = a
 	senddirect [] = return False
@@ -287,8 +277,12 @@ sendAnnex key a = withObjectLoc key sendobject senddirect
 			( do
 				r <- sendobject f
 				-- see if file changed while it was being sent
-				ok <- compareCache f cache
-				return (r && ok)
+				ifM (compareCache f cache)
+					( return r
+					, do
+						rollback
+						return False
+					)
 			, senddirect fs
 			)
 

Command/SendKey.hs

@@ -24,11 +24,16 @@ seek = [withKeys start]
 start :: Key -> CommandStart
 start key = ifM (inAnnex key)
 	( fieldTransfer Upload key $ \_p ->
-		sendAnnex key $ liftIO . rsyncServerSend
+		sendAnnex key rollback $ liftIO . rsyncServerSend
 	, do
 		warning "requested key is not present"
 		liftIO exitFailure
 	)
+  where
+	{- No need to do any rollback; when sendAnnex fails, a nonzero
+	 - exit will be propigated, and the remote will know the transfer
+	 - failed. -}
+	rollback = noop
 
 fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart
 fieldTransfer direction key a = do

Remote/Bup.hs

@@ -121,16 +121,17 @@ bupSplitParams r buprepo k src = do
 		(os ++ [Param "-n", Param (bupRef k)] ++ src)
 
 store :: Remote -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store r buprepo k _f _p = sendAnnex k $ \src -> do
+store r buprepo k _f _p = sendAnnex k (rollback k buprepo) $ \src -> do
 	params <- bupSplitParams r buprepo k [File src]
 	liftIO $ boolSystem "bup" params
 
 storeEncrypted :: Remote -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
-storeEncrypted r buprepo (cipher, enck) k _p = sendAnnex k $ \src -> do
-	params <- bupSplitParams r buprepo enck []
-	liftIO $ catchBoolIO $
-		encrypt cipher (feedFile src) $ \h ->
-			pipeBup params (Just h) Nothing
+storeEncrypted r buprepo (cipher, enck) k _p =
+	sendAnnex k (rollback enck buprepo) $ \src -> do
+		params <- bupSplitParams r buprepo enck []
+		liftIO $ catchBoolIO $
+			encrypt cipher (feedFile src) $ \h ->
+				pipeBup params (Just h) Nothing
 
 retrieve :: BupRepo -> Key -> AssociatedFile -> FilePath -> Annex Bool
 retrieve buprepo k _f d = do
@@ -157,6 +158,20 @@ remove _ = do
 	warning "content cannot be removed from bup remote"
 	return False
 
+{- Cannot revert having stored a key in bup, but at least the data for the
+ - key will be used for deltaing data of other keys stored later.
+ -
+ - We can, however, remove the git branch that bup created for the key.
+ -}
+rollback :: Key -> BupRepo -> Annex ()
+rollback k bupr = go =<< liftIO (bup2GitRemote bupr)
+  where
+	go r
+		| Git.repoIsUrl r = void $ onBupRemote r boolSystem "git" params
+		| otherwise = void $ liftIO $ catchMaybeIO $
+			boolSystem "git" $ Git.Command.gitCommandLine params r
+	params = [ Params "branch -D", Param (bupRef k) ]
+
 {- Bup does not provide a way to tell if a given dataset is present
  - in a bup repository. One way it to check if the git repository has
  - a branch matching the name (as created by bup split -n).

Remote/Directory.hs

@@ -111,7 +111,7 @@ withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO
 withStoredFiles = withCheckedFiles doesFileExist
 
 store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store d chunksize k _f p = sendAnnex k $ \src ->
+store d chunksize k _f p = sendAnnex k (void $ remove d k) $ \src ->
 	metered (Just p) k $ \meterupdate -> 
 		storeHelper d chunksize k $ \dests ->
 			case chunksize of
@@ -125,7 +125,7 @@ store d chunksize k _f p = sendAnnex k $ \src ->
 						=<< L.readFile src
 
 storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
-storeEncrypted d chunksize (cipher, enck) k p = sendAnnex k $ \src -> 
+storeEncrypted d chunksize (cipher, enck) k p = sendAnnex k (void $ remove d enck) $ \src -> 
 	metered (Just p) k $ \meterupdate ->
 		storeHelper d chunksize enck $ \dests ->
 			encrypt cipher (feedFile src) $ readBytes $ \b ->

Remote/Git.hs

@@ -268,7 +268,7 @@ copyFromRemote r key file dest
 		-- run copy from perspective of remote
 		liftIO $ onLocal (repo r) $ do
 			ensureInitialized
-			Annex.Content.sendAnnex key $ \object ->
+			Annex.Content.sendAnnex key noop $ \object ->
 				upload u key file noRetry $
 					rsyncOrCopyFile params object dest
 	| Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> 
@@ -333,11 +333,11 @@ copyToRemote r key file p
 	| not $ Git.repoIsUrl (repo r) =
 		guardUsable (repo r) False $ commitOnCleanup r $ copylocal
 	| Git.repoIsSsh (repo r) = commitOnCleanup r $
-		Annex.Content.sendAnnex key $ \object ->
+		Annex.Content.sendAnnex key noop $ \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
+	copylocal = Annex.Content.sendAnnex key noop $ \object -> do
 		let params = rsyncParams r
 		u <- getUUID
 		-- run copy from perspective of remote

Remote/Glacier.hs

@@ -85,12 +85,12 @@ store r k _f m
 	| keySize k == Just 0 = do
 		warning "Cannot store empty files in Glacier."
 		return False
-	| otherwise = sendAnnex k $ \src ->
+	| otherwise = sendAnnex k (void $ remove r k) $ \src ->
 		metered (Just m) k $ \meterupdate ->
 			storeHelper r k $ streamMeteredFile src meterupdate
 
 storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
-storeEncrypted r (cipher, enck) k m = sendAnnex k $ \src -> do
+storeEncrypted r (cipher, enck) k m = sendAnnex k (void $ remove r enck) $ \src -> do
 	metered (Just m) k $ \meterupdate ->
 		storeHelper r enck $ \h ->
 			encrypt cipher (feedFile src)

Remote/Hook.hs

@@ -103,12 +103,12 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h
 			)
 
 store :: String -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store h k _f _p = sendAnnex k $ \src ->
+store h k _f _p = sendAnnex k (void $ remove h k) $ \src ->
 	runHook h "store" k (Just src) $ return True
 
 storeEncrypted :: String -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
 storeEncrypted h (cipher, enck) k _p = withTmp enck $ \tmp ->
-	sendAnnex k $ \src -> do
+	sendAnnex k (void $ remove h enck) $ \src -> do
 		liftIO $ encrypt cipher (feedFile src) $
 			readBytes $ L.writeFile tmp
 		runHook h "store" enck (Just tmp) $ return True

Remote/Rsync.hs

@@ -101,11 +101,11 @@ rsyncUrls o k = map use annexHashes
 	f = keyFile k
 
 store :: RsyncOpts -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store o k _f p = sendAnnex k $ rsyncSend o p k
+store o k _f p = sendAnnex k (void $ remove o k) $ rsyncSend o p k
 
 storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
 storeEncrypted o (cipher, enck) k p = withTmp enck $ \tmp ->
-	sendAnnex k $ \src -> do
+	sendAnnex k (void $ remove o enck) $ \src -> do
 		liftIO $ encrypt cipher (feedFile src) $
 			readBytes $ L.writeFile tmp
 		rsyncSend o p enck tmp

Remote/S3.hs

@@ -112,15 +112,16 @@ s3Setup u c = handlehost $ M.lookup "host" c
 			M.delete "bucket" defaults
 
 store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store r k _f p = s3Action r False $ \(conn, bucket) -> sendAnnex k $ \src -> do
-	res <- storeHelper (conn, bucket) r k p src
-	s3Bool res
+store r k _f p = s3Action r False $ \(conn, bucket) -> 
+	sendAnnex k (void $ remove r k) $ \src -> do
+		res <- storeHelper (conn, bucket) r k p src
+		s3Bool res
 
 storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
 storeEncrypted r (cipher, enck) k p = s3Action r False $ \(conn, bucket) -> 
 	-- To get file size of the encrypted content, have to use a temp file.
 	-- (An alternative would be chunking to to a constant size.)
-	withTmp enck $ \tmp -> sendAnnex k $ \src -> do
+	withTmp enck $ \tmp -> sendAnnex k (void $ remove r enck) $ \src -> do
 		liftIO $ encrypt cipher (feedFile src) $
 			readBytes $ L.writeFile tmp
 		res <- storeHelper (conn, bucket) r enck p tmp

Remote/WebDAV.hs

@@ -83,15 +83,17 @@ webdavSetup u c = do
 
 store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
 store r k _f p = metered (Just p) k $ \meterupdate ->
-	davAction r False $ \(baseurl, user, pass) -> sendAnnex k $ \src ->
-		liftIO $ withMeteredFile src meterupdate $
-			storeHelper r k baseurl user pass
+	davAction r False $ \(baseurl, user, pass) -> 
+		sendAnnex k (void $ remove r k) $ \src ->
+			liftIO $ withMeteredFile src meterupdate $
+				storeHelper r k baseurl user pass
 
 storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
 storeEncrypted r (cipher, enck) k p = metered (Just p) k $ \meterupdate ->
-	davAction r False $ \(baseurl, user, pass) -> sendAnnex k $ \src ->
-		liftIO $ encrypt cipher (streamMeteredFile src meterupdate) $
-			readBytes $ storeHelper r enck baseurl user pass
+	davAction r False $ \(baseurl, user, pass) ->
+		sendAnnex k (void $ remove r enck) $ \src ->
+			liftIO $ encrypt cipher (streamMeteredFile src meterupdate) $
+				readBytes $ storeHelper r enck baseurl user pass
 
 storeHelper :: Remote -> Key -> DavUrl -> DavUser -> DavPass -> L.ByteString -> IO Bool
 storeHelper r k baseurl user pass b = catchBoolIO $ do

debian/changelog

@@ -1,6 +1,8 @@
 git-annex (3.20130108) UNRELEASED; urgency=low
 
   * fsck: Better checking of file content in direct mode.
+  * Special remotes now all rollback storage of keys that get modified
+    during the transfer, which can happen in direct mode.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 08 Jan 2013 12:37:38 -0400