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'