make export and sync update special remote tracking branch

The branch is only updated once the export is 100% complete. This way, if an export is started but interrupted and so the remote does not yet contain some of the files, an import will make a commit on the old branch, and so won't delete the missing files.
2019-03-01 16:08:18 -04:00 · 2019-03-01 16:08:18 -04:00 · 18d7a1dbbb
commit 18d7a1dbbb
parent 519cadd1de
5 changed files with 98 additions and 46 deletions
--- a/10
+++ b/10
@ -1,14 +1,18 @@
 git-annex (7.20190220) UNRELEASED; urgency=medium

+  * New feature allows importing from special remotes, using
+    git annex import branch:subdir --from remote
+  * export: Deprecated the --tracking option.
+    Instead, users can configure remote.<name>.annex-tracking-branch
+    themselves.
+  * Remote tracking branches are updated when importing and exporting to
+    special remotes, in ways analagous to how git fetch and git push do.
  * Fix storage of metadata values containing newlines.
    (Reversion introduced in version 7.20190122.)
  * Sped up git-annex export in repositories with lots of keys.
  * S3: Support enabling bucket versioning when built with aws-0.21.1.
  * stack.yaml: Build with aws-0.21.1
  * Fix cleanup of git-annex:export.log after git-annex forget --drop-dead.
-  * export: Deprecated the --tracking option.
-    Instead, users can configure remote.<name>.annex-tracking-branch
-    themselves.

 -- Joey Hess <id@joeyh.name>  Wed, 20 Feb 2019 14:20:59 -0400

--- a/Command/Export.hs
+++ b/Command/Export.hs
@ -1,6 +1,6 @@
 {- git-annex command
 -
- - Copyright 2017 Joey Hess <id@joeyh.name>
+ - Copyright 2017-2019 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
@ -25,6 +25,7 @@ import Annex.Content
 import Annex.Transfer
 import Annex.CatFile
 import Annex.LockFile
+import Annex.RemoteTrackingBranch
 import Logs.Location
 import Logs.Export
 import Database.Export
@ -43,6 +44,7 @@ cmd = command "export" SectionCommon

 data ExportOptions = ExportOptions
 	{ exportTreeish :: Git.Ref
+	-- ^ can be a tree, a branch, a commit, or a tag
 	, exportRemote :: DeferredParse Remote
 	, exportTracking :: Bool
 	}
@ -72,20 +74,37 @@ seek o = do
 	r <- getParsed (exportRemote o)
 	unlessM (isExportSupported r) $
 		giveup "That remote does not support exports."
+	
+	-- handle deprecated option
 	when (exportTracking o) $
 		setConfig (remoteConfig r "annex-tracking-branch")
 			(fromRef $ exportTreeish o)
-	new <- fromMaybe (giveup "unknown tree") <$>
-		-- Dereference the tree pointed to by the branch, commit,
-		-- or tag.
-		inRepo (Git.Ref.tree (exportTreeish o))
+	
+	mtbcommitsha <- getExportCommit r (exportTreeish o)
+	tree <- fromMaybe (giveup "unknown tree") <$>
+		inRepo (Git.Ref.tree (fromMaybe (exportTreeish o) (fmap snd mtbcommitsha)))
+
 	withExclusiveLock (gitAnnexExportLock (uuid r)) $ do
 		db <- openDb (uuid r)
-		changeExport r db new
-		unlessM (Annex.getState Annex.fast) $
-			void $ fillExport r db new
+		changeExport r db tree
+		unlessM (Annex.getState Annex.fast) $ do
+			void $ fillExport r db tree mtbcommitsha
 		closeDb db

+-- | When the treeish is a branch like master or refs/heads/master
+-- (but not refs/remotes/...), find the commit it points to
+-- and the corresponding remote tracking branch.
+getExportCommit :: Remote -> Git.Ref -> Annex (Maybe (RemoteTrackingBranch, Sha))
+getExportCommit r treeish
+	| '/' `notElem` fromRef baseref = do
+		let tb = mkRemoteTrackingBranch r baseref
+		commitsha <- inRepo $ Git.Ref.sha $ Git.Ref.underBase refsheads baseref
+		return (fmap (tb, ) commitsha)
+	| otherwise = return Nothing
+  where
+	baseref = Git.Ref.removeBase refsheads treeish
+	refsheads = "refs/heads"
+
 -- | Changes what's exported to the remote. Does not upload any new
 -- files, but does delete and rename files already exported to the remote.
 changeExport :: Remote -> ExportHandle -> Git.Ref -> CommandSeek
@ -189,26 +208,42 @@ mkDiffMap old new db = do
 		| sha == nullSha = return Nothing
 		| otherwise = Just <$> exportKey sha

-- | Upload all exported files that are not yet in the remote,
-- Returns True when files were uploaded.
-fillExport :: Remote -> ExportHandle -> Git.Ref -> Annex Bool
-fillExport r db new = do
-	(l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive new
-	cvar <- liftIO $ newMVar False
-	commandActions $ map (startExport r db cvar) l
-	void $ liftIO $ cleanup
-	liftIO $ takeMVar cvar
+newtype FileUploaded = FileUploaded { fromFileUploaded :: Bool }

-startExport :: Remote -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart
-startExport r db cvar ti = do
+newtype AllFilled = AllFilled { fromAllFilled :: Bool }
+
+-- | Upload all exported files that are not yet in the remote.
+--
+-- Returns True when some files were uploaded (perhaps not all of them).
+--
+-- Once all exported files have reached the remote, updates the
+-- remote tracking branch.
+fillExport :: Remote -> ExportHandle -> Git.Ref -> Maybe (RemoteTrackingBranch, Sha) -> Annex Bool
+fillExport r db newtree mtbcommitsha = do
+	(l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive newtree
+	cvar <- liftIO $ newMVar (FileUploaded False)
+	allfilledvar <- liftIO $ newMVar (AllFilled True)
+	commandActions $ map (startExport r db cvar allfilledvar) l
+	void $ liftIO $ cleanup
+
+	case mtbcommitsha of
+		Nothing -> noop
+		Just (tb, commitsha) ->
+			whenM (liftIO $ fromAllFilled <$> takeMVar allfilledvar) $
+				setRemoteTrackingBranch tb commitsha
+	
+	liftIO $ fromFileUploaded <$> takeMVar cvar
+
+startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled -> Git.LsTree.TreeItem -> CommandStart
+startExport r db cvar allfilledvar ti = do
 	ek <- exportKey (Git.LsTree.sha ti)
 	stopUnless (notrecordedpresent ek) $ do
 		showStart ("export " ++ name r) f
 		ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
 			( next $ next $ cleanupExport r db ek loc False
 			, do
-				liftIO $ modifyMVar_ cvar (pure . const True)
-				next $ performExport r db ek af (Git.LsTree.sha ti) loc
+				liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))
+				next $ performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
 			)
  where
 	loc = mkExportLocation f
@ -220,8 +255,8 @@ startExport r db cvar ti = do
 		-- will still list it, so also check location tracking.
 		<*> (notElem (uuid r) <$> loggedLocations (asKey ek))

-performExport :: Remote -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform
-performExport r db ek af contentsha loc = do
+performExport :: Remote -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> MVar AllFilled -> CommandPerform
+performExport r db ek af contentsha loc allfilledvar = do
 	let storer = storeExport (exportActions r)
 	sent <- case ek of
 		AnnexKey k -> ifM (inAnnex k)
@ -246,7 +281,9 @@ performExport r db ek af contentsha loc = do
 				storer tmp sha1k loc nullMeterUpdate
 	if sent
 		then next $ cleanupExport r db ek loc True
-		else stop
+		else do
+			liftIO $ modifyMVar_ allfilledvar (pure . const (AllFilled False))
+			stop

 cleanupExport :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> Bool -> CommandCleanup
 cleanupExport r db ek loc sent = do
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@ -1,11 +1,13 @@
 {- git-annex command
 -
 - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
- - Copyright 2011-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

+{-# LANGUAGE FlexibleContexts #-}
+
 module Command.Sync (
 	cmd,
 	CurrBranch,
@ -691,21 +693,25 @@ seekExportContent rs (currbranch, _) = or <$> forM rs go
  where
 	go r = withExclusiveLock (gitAnnexExportLock (Remote.uuid r)) $ do
 		db <- Export.openDb (Remote.uuid r)
-		exported <- case remoteAnnexTrackingBranch (Remote.gitconfig r) of
+		(exported, mtbcommitsha) <- case remoteAnnexTrackingBranch (Remote.gitconfig r) of
 			Nothing -> nontracking r
 			Just b -> do
-				mcur <- inRepo $ Git.Ref.tree b
+				mtbcommitsha <- Command.Export.getExportCommit r b
+				mcur <- maybe
+					(return Nothing)
+					(inRepo . Git.Ref.tree)
+					(fmap snd mtbcommitsha)
 				case mcur of
 					Nothing -> nontracking r
 					Just cur -> do
 						Command.Export.changeExport r db cur
-						return [mkExported cur []]
-		Export.closeDb db `after` fillexport r db (exportedTreeishes exported)
+						return ([mkExported cur []], mtbcommitsha)
+		Export.closeDb db `after` fillexport r db (exportedTreeishes exported) mtbcommitsha
 		
 	nontracking r = do
 		exported <- getExport (Remote.uuid r)
 		maybe noop (warnnontracking r exported) currbranch
-		return exported
+		return (exported, Nothing)
 	
 	warnnontracking r exported currb = inRepo (Git.Ref.tree currb) >>= \case
 		Just currt | not (any (== currt) (exportedTreeishes exported)) ->
@ -713,15 +719,15 @@ seekExportContent rs (currbranch, _) = or <$> forM rs go
 				[ "Not updating export to " ++ Remote.name r
 				, "to reflect changes to the tree, because export"
 				, "tracking is not enabled. "
-				, "(Use git-annex export's --tracking option"
-				, "to enable it.)"
+				, "(Set " ++ gitconfig ++ " to enable it.)"
 				]
 		_ -> noop
+	  where
+		gitconfig = show (remoteConfig r "annex-tracking-branch")

-
-	fillexport _ _ [] = return False
-	fillexport r db (t:[]) = Command.Export.fillExport r db t
-	fillexport r _ _ = do
+	fillexport _ _ [] _ = return False
+	fillexport r db (t:[]) mtbcommitsha = Command.Export.fillExport r db t mtbcommitsha
+	fillexport r _ _ _ = do
 		warnExportConflict r
 		return False

--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@ -1,6 +1,6 @@
 {- git ref stuff
 -
- - Copyright 2011-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
@ -33,11 +33,18 @@ describe = fromRef . base
 - Converts such a fully qualified ref into a base ref
 - (eg: master or origin/master). -}
 base :: Ref -> Ref
-base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
+base = removeBase "refs/heads/" . removeBase "refs/remotes/"
+
+{- Removes a directory such as "refs/heads/master" from a
+ - fully qualified ref. Any ref not starting with it is left as-is. -}
+removeBase :: String -> Ref -> Ref
+removeBase dir (Ref r)
+	| prefix `isPrefixOf` r = Ref (drop (length prefix) r)
+	| otherwise = Ref r
  where
-	remove prefix s
-		| prefix `isPrefixOf` s = drop (length prefix) s
-		| otherwise = s
+	prefix = case end dir of
+		['/'] -> dir
+		_ -> dir ++ "/"

 {- Given a directory such as "refs/remotes/origin", and a ref such as
 - refs/heads/master, yields a version of that ref under the directory,
--- a/doc/todo/import_tree.mdwn
+++ b/doc/todo/import_tree.mdwn
@ -21,8 +21,6 @@ this.
 * export needs to use storeExportWithContentIdentifierM for importtree=yes
  remotes

-* export needs to update the tracking branch with what it exported
-
 * "git annex import master --from rmt" followed by "git annex import master:sub --from rmt"
  first makes the tracking branch contain only what's in the remote,
  and then grafts what's in the remote into a subdir. Is that the behavior