From 7d0d4d5b6ab2fd23c664742e5a1e7ed019b0c40d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 19 Sep 2017 14:20:47 -0400 Subject: git annex sync --content to exports Assistant still todo. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon --- Command/Export.hs | 61 +++++++++++++++++++++++++++++++------------------------ Command/Sync.hs | 50 +++++++++++++++++++++++++++++++++++++++------ 2 files changed, 79 insertions(+), 32 deletions(-) (limited to 'Command') diff --git a/Command/Export.hs b/Command/Export.hs index 81013ad47..0afcc3af1 100644 --- a/Command/Export.hs +++ b/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' diff --git a/Command/Sync.hs b/Command/Sync.hs index d460679ba..3a838c8a9 100644 --- a/Command/Sync.hs +++ b/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 -- cgit v1.2.3