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 --- Annex/Export.hs | 8 +++++++ Command/Export.hs | 61 ++++++++++++++++++++++++++++--------------------- Command/Sync.hs | 50 +++++++++++++++++++++++++++++++++++----- Remote/Helper/Export.hs | 6 +---- Remote/S3.hs | 1 + doc/todo/export.mdwn | 2 +- 6 files changed, 90 insertions(+), 38 deletions(-) diff --git a/Annex/Export.hs b/Annex/Export.hs index 0afe3cdcc..6565c257b 100644 --- a/Annex/Export.hs +++ b/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 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 diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs index d62c5a7e8..f5c3585c5 100644 --- a/Remote/Helper/Export.hs +++ b/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 diff --git a/Remote/S3.hs b/Remote/S3.hs index 52d03ba94..5e76b9810 100644 --- a/Remote/S3.hs +++ b/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 diff --git a/doc/todo/export.mdwn b/doc/todo/export.mdwn index 876c54c77..7500de097 100644 --- a/doc/todo/export.mdwn +++ b/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). -- cgit v1.2.3