git annex sync --content to exports

Assistant still todo.

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon

Annex/Export.hs

@@ -10,8 +10,11 @@ module Annex.Export where
 import Annex
 import Annex.CatFile
 import Types.Key
+import Types.Remote
 import qualified Git
 
+import qualified Data.Map as M
+
 -- An export includes both annexed files and files stored in git.
 -- For the latter, a SHA1 key is synthesized.
 data ExportKey = AnnexKey Key | GitKey Key
@@ -33,3 +36,8 @@ exportKey sha = mk <$> catKey sha
 		, keyChunkSize = Nothing
 		, keyChunkNum = Nothing
 		}
+
+exportTree :: RemoteConfig -> Bool
+exportTree c = case M.lookup "exporttree" c of
+	Just "yes" -> True
+	_ -> False

Command/Export.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections, BangPatterns #-}
 
 module Command.Export where
 
@@ -33,6 +33,7 @@ import Utility.Tmp
 
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Map as M
+import Control.Concurrent
 
 cmd :: Command
 cmd = command "export" SectionCommon
@@ -70,23 +71,27 @@ seek o = do
 	r <- getParsed (exportRemote o)
 	unlessM (isExportSupported r) $
 		giveup "That remote does not support exports."
-	withExclusiveLock (gitAnnexExportLock (uuid r)) (seek' o r)
-
-seek' :: ExportOptions -> Remote -> CommandSeek
-seek' o r = do
+	when (exportTracking o) $
+		setConfig (remoteConfig r "export-tracking")
+			(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))
+	withExclusiveLock (gitAnnexExportLock (uuid r)) $ do
+		db <- openDb (uuid r)
+		ea <- exportActions r
+		changeExport r ea db new
+		void $ fillExport r ea db new
+		closeDb db
+
+-- | 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 -> ExportActions Annex -> ExportHandle -> Git.Ref -> CommandSeek
+changeExport r ea db new = do
 	old <- getExport (uuid r)
-	db <- openDb (uuid r)
-	ea <- exportActions r
 	recordExportBeginning (uuid r) new
 	
-	when (exportTracking o) $
-		setConfig (remoteConfig r "export-tracking")
-			(fromRef $ exportTreeish o)
-
 	-- Clean up after incomplete export of a tree, in which
 	-- the next block of code below may have renamed some files to
 	-- temp files. Diff from the incomplete tree to the new tree,
@@ -150,13 +155,6 @@ seek' o r = do
 			{ oldTreeish = map exportedTreeish old
 			, newTreeish = new
 			}
-
-	-- Export everything that is not yet exported.
-	(l, cleanup') <- inRepo $ Git.LsTree.lsTree new
-	seekActions $ pure $ map (startExport r ea db) l
-	void $ liftIO cleanup'
-
-	closeDb db
   where
 	mapdiff a oldtreesha newtreesha = do
 		(diff, cleanup) <- inRepo $
@@ -187,11 +185,22 @@ mkDiffMap old new db = do
 		| sha == nullSha = return Nothing
 		| otherwise = Just <$> exportKey sha
 
-startExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.LsTree.TreeItem -> CommandStart
-startExport r ea db ti = do
+-- | Upload all exported files that are not yet in the remote,
+-- Returns True when files were uploaded.
+fillExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> Annex Bool
+fillExport r ea db new = do
+	(l, cleanup) <- inRepo $ Git.LsTree.lsTree new
+	cvar <- liftIO $ newMVar False
+	seekActions $ pure $ map (startExport r ea db cvar) l
+	void $ liftIO $ cleanup
+	liftIO $ takeMVar cvar
+
+startExport :: Remote -> ExportActions Annex -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart
+startExport r ea db cvar ti = do
 	ek <- exportKey (Git.LsTree.sha ti)
 	stopUnless (liftIO $ notElem loc <$> getExportedLocation db (asKey ek)) $ do
-		showStart "export" f
+		showStart ("export " ++ name r) f
+		liftIO $ modifyMVar_ cvar (pure . const True)
 		next $ performExport r ea db ek (Git.LsTree.sha ti) loc
   where
 	loc = mkExportLocation f
@@ -234,7 +243,7 @@ startUnexport r ea db f shas = do
 	if null eks
 		then stop
 		else do
-			showStart "unexport" f'
+			showStart ("unexport " ++ name r) f'
 			next $ performUnexport r ea db eks loc
   where
 	loc = mkExportLocation f'
@@ -242,7 +251,7 @@ startUnexport r ea db f shas = do
 
 startUnexport' :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
 startUnexport' r ea db f ek = do
-	showStart "unexport" f'
+	showStart ("unexport " ++ name r) f'
 	next $ performUnexport r ea db [ek] loc
   where
 	loc = mkExportLocation f'
@@ -276,7 +285,7 @@ startRecoverIncomplete r ea db sha oldf
 	| otherwise = do
 		ek <- exportKey sha
 		let loc = exportTempName ek
-		showStart "unexport" (fromExportLocation loc)
+		showStart ("unexport " ++ name r) (fromExportLocation loc)
 		liftIO $ removeExportedLocation db (asKey ek) oldloc
 		next $ performUnexport r ea db [ek] loc
   where
@@ -285,7 +294,7 @@ startRecoverIncomplete r ea db sha oldf
 
 startMoveToTempName :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
 startMoveToTempName r ea db f ek = do
-	showStart "rename" (f' ++ " -> " ++ fromExportLocation tmploc)
+	showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)
 	next $ performRename r ea db ek loc tmploc
   where
 	loc = mkExportLocation f'
@@ -296,7 +305,7 @@ startMoveFromTempName :: Remote -> ExportActions Annex -> ExportHandle -> Export
 startMoveFromTempName r ea db ek f = do
 	let tmploc = exportTempName ek
 	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do
-		showStart "rename" (fromExportLocation tmploc ++ " -> " ++ f')
+		showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')
 		next $ performRename r ea db ek tmploc loc
   where
 	loc = mkExportLocation f'

Command/Sync.hs

@@ -46,14 +46,19 @@ import Annex.Wanted
 import Annex.Content
 import Command.Get (getKey')
 import qualified Command.Move
+import qualified Command.Export
 import Annex.Drop
 import Annex.UUID
 import Logs.UUID
+import Logs.Export
 import Annex.AutoMerge
 import Annex.AdjustedBranch
 import Annex.Ssh
 import Annex.BloomFilter
 import Annex.UpdateInstead
+import Annex.Export
+import Annex.LockFile
+import qualified Database.Export as Export
 import Utility.Bloom
 import Utility.OptParse
 
@@ -153,7 +158,8 @@ seek o = allowConcurrentOutput $ do
 
 	remotes <- syncRemotes (syncWith o)
 	let gitremotes = filter Remote.gitSyncableRemote remotes
-	dataremotes <- filter (\r -> Remote.uuid r /= NoUUID)
+	(exportremotes, dataremotes) <- partition (exportTree . Remote.config)
+		. filter (\r -> Remote.uuid r /= NoUUID)
 		<$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes
 
 	-- Syncing involves many actions, any of which can independently
@@ -165,16 +171,19 @@ seek o = allowConcurrentOutput $ do
 		, map (withbranch . pullRemote o mergeConfig) gitremotes
 		,  [ mergeAnnex ]
 		]
-	whenM (shouldsynccontent <&&> seekSyncContent o dataremotes) $
+	whenM shouldsynccontent $ do
+		syncedcontent <- seekSyncContent o dataremotes
+		exportedcontent <- seekExportContent exportremotes
 		-- Transferring content can take a while,
 		-- and other changes can be pushed to the git-annex
 		-- branch on the remotes in the meantime, so pull
 		-- and merge again to avoid our push overwriting
 		-- those changes.
-		mapM_ includeCommandAction $ concat
-			[ map (withbranch . pullRemote o mergeConfig) gitremotes
-			, [ commitAnnex, mergeAnnex ]
-			]
+		when (syncedcontent || exportedcontent) $ do
+			mapM_ includeCommandAction $ concat
+				[ map (withbranch . pullRemote o mergeConfig) gitremotes
+				, [ commitAnnex, mergeAnnex ]
+				]
 	
 	void $ includeCommandAction $ withbranch pushLocal
 	-- Pushes to remotes can run concurrently.
@@ -640,3 +649,32 @@ syncFile ebloom rs af k = do
 		)
 	put dest = includeCommandAction $ 
 		Command.Move.toStart' dest False af k (mkActionItem af)
+
+{- When a remote has an export-tracking branch, change the export to
+ - follow the current content of the branch. Otherwise, transfer any files
+ - that were part of an export but are not in the remote yet. -}
+seekExportContent :: [Remote] -> Annex Bool
+seekExportContent rs = or <$> forM rs go
+  where
+	go r = withExclusiveLock (gitAnnexExportLock (Remote.uuid r)) $ do
+		db <- Export.openDb (Remote.uuid r)
+		ea <- Remote.exportActions r
+		exported <- case remoteAnnexExportTracking (Remote.gitconfig r) of
+			Nothing -> getExport (Remote.uuid r)
+			Just b -> do
+				mcur <- inRepo $ Git.Ref.tree b
+				case mcur of
+					Nothing -> getExport (Remote.uuid r)
+					Just cur -> do
+						Command.Export.changeExport r ea db cur
+						return [Exported cur []]
+		Export.closeDb db `after` fillexport r ea db exported
+
+	fillexport _ _ _ [] = return False
+	fillexport r ea db (Exported { exportedTreeish = t }:[]) =
+		Command.Export.fillExport r ea db t
+	fillexport r _ _ _ = do
+		warning $ "Export conflict detected. Different trees have been exported to " ++ 
+			Remote.name r ++ 
+			". Use git-annex export to resolve this conflict."
+		return False

Remote/Helper/Export.hs

@@ -17,6 +17,7 @@ import Backend
 import Remote.Helper.Encryptable (isEncrypted)
 import Database.Export
 import Logs.Export
+import Annex.Export
 import Annex.LockFile
 import Git.Sha
 
@@ -42,11 +43,6 @@ instance HasExportUnsupported (Annex (ExportActions Annex)) where
 		, renameExport = \_ _ _ -> return False
 		}
 
-exportTree :: RemoteConfig -> Bool
-exportTree c = case M.lookup "exporttree" c of
-	Just "yes" -> True
-	_ -> False
-
 exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
 exportIsSupported = \_ _ -> return True
 

Remote/S3.hs

@@ -34,6 +34,7 @@ import System.Log.Logger
 import Annex.Common
 import Types.Remote
 import Types.Export
+import Annex.Export
 import qualified Git
 import Config
 import Config.Cost

doc/todo/export.mdwn

@@ -17,7 +17,7 @@ there need to be a new interface in supported remotes?
 
 Work is in progress. Todo list:
 
-* tracking exports
+* Make assistant update tracking exports.
 
 * Support configuring export in the assistant
   (when eg setting up a S3 special remote).