git annex sync --content to exports

Assistant still todo.

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon
This commit is contained in:
Joey Hess 2017-09-19 14:20:47 -04:00
parent 527f734492
commit 2e69efea8d
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
6 changed files with 90 additions and 38 deletions

View file

@ -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'

View file

@ -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