summaryrefslogtreecommitdiff
path: root/Command
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2017-09-12 16:59:04 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2017-09-12 16:59:04 -0400
commitb2fcdcc0a97add0ba0a518fb991f57431937c2a9 (patch)
treefddebae7627ee9c9b03cc4f8aff736c05dadaec1 /Command
parent9bb67ce329578be45b598c98b17283c3bb9dfd43 (diff)
export: cache connections for S3 and webdav
Diffstat (limited to 'Command')
-rw-r--r--Command/Export.hs76
1 files changed, 40 insertions, 36 deletions
diff --git a/Command/Export.hs b/Command/Export.hs
index 8f1a6f149..611656581 100644
--- a/Command/Export.hs
+++ b/Command/Export.hs
@@ -89,15 +89,18 @@ seek o = do
-- or tag.
inRepo (Git.Ref.tree (exportTreeish o))
old <- getExport (uuid r)
- recordExportBeginning (uuid r) new
db <- openDb (uuid r)
+ ea <- exportActions r
+ recordExportBeginning (uuid r) new
+ liftIO $ print (old, new)
+
-- 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,
-- and delete any temp files that the new tree can't use.
forM_ (concatMap incompleteExportedTreeish old) $ \incomplete ->
- mapdiff (\diff -> startRecoverIncomplete r db (Git.DiffTree.srcsha diff) (Git.DiffTree.file diff))
+ mapdiff (\diff -> startRecoverIncomplete r ea db (Git.DiffTree.srcsha diff) (Git.DiffTree.file diff))
incomplete
new
@@ -115,15 +118,15 @@ seek o = do
seekdiffmap $ \(ek, (moldf, mnewf)) ->
case (moldf, mnewf) of
(Just oldf, Just _newf) ->
- startMoveToTempName r db oldf ek
+ startMoveToTempName r ea db oldf ek
(Just oldf, Nothing) ->
- startUnexport' r db oldf ek
+ startUnexport' r ea db oldf ek
_ -> stop
-- Rename from temp to new files.
seekdiffmap $ \(ek, (moldf, mnewf)) ->
case (moldf, mnewf) of
(Just _oldf, Just newf) ->
- startMoveFromTempName r db ek newf
+ startMoveFromTempName r ea db ek newf
_ -> stop
ts -> do
warning "Export conflict detected. Different trees have been exported to the same special remote. Resolving.."
@@ -139,7 +142,7 @@ seek o = do
-- Don't rename to temp, because the
-- content is unknown; delete instead.
mapdiff
- (\diff -> startUnexport r db (Git.DiffTree.file diff) (unexportboth diff))
+ (\diff -> startUnexport r ea db (Git.DiffTree.file diff) (unexportboth diff))
oldtreesha new
-- Waiting until now to record the export guarantees that,
@@ -154,7 +157,7 @@ seek o = do
-- Export everything that is not yet exported.
(l, cleanup') <- inRepo $ Git.LsTree.lsTree new
- seekActions $ pure $ map (startExport r db) l
+ seekActions $ pure $ map (startExport r ea db) l
void $ liftIO cleanup'
closeDb db
@@ -187,23 +190,24 @@ mkDiffMap old new = do
| sha == nullSha = return Nothing
| otherwise = Just <$> exportKey sha
-startExport :: Remote -> ExportHandle -> Git.LsTree.TreeItem -> CommandStart
-startExport r db ti = do
+startExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.LsTree.TreeItem -> CommandStart
+startExport r ea db ti = do
ek <- exportKey (Git.LsTree.sha ti)
stopUnless (liftIO $ notElem loc <$> getExportLocation db (asKey ek)) $ do
showStart "export" f
- next $ performExport r db ek (Git.LsTree.sha ti) loc
+ next $ performExport r ea db ek (Git.LsTree.sha ti) loc
where
loc = ExportLocation $ toInternalGitPath f
f = getTopFilePath $ Git.LsTree.file ti
-performExport :: Remote -> ExportHandle -> ExportKey -> Sha -> ExportLocation -> CommandPerform
-performExport r db ek contentsha loc = do
- let storer = storeExport $ exportActions r
+performExport :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> Sha -> ExportLocation -> CommandPerform
+performExport r ea db ek contentsha loc = do
+ let storer = storeExport ea
sent <- case ek of
AnnexKey k -> ifM (inAnnex k)
( metered Nothing k $ \m -> do
- let rollback = void $ performUnexport r db [ek] loc
+ let rollback = void $
+ performUnexport r ea db [ek] loc
sendAnnex k rollback
(\f -> storer f k loc m)
, do
@@ -227,29 +231,29 @@ cleanupExport r db ek loc = do
logChange (asKey ek) (uuid r) InfoPresent
return True
-startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
-startUnexport r db f shas = do
+startUnexport :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
+startUnexport r ea db f shas = do
eks <- forM (filter (/= nullSha) shas) exportKey
if null eks
then stop
else do
showStart "unexport" f'
- next $ performUnexport r db eks loc
+ next $ performUnexport r ea db eks loc
where
loc = ExportLocation $ toInternalGitPath f'
f' = getTopFilePath f
-startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
-startUnexport' r db f ek = do
+startUnexport' :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
+startUnexport' r ea db f ek = do
showStart "unexport" f'
- next $ performUnexport r db [ek] loc
+ next $ performUnexport r ea db [ek] loc
where
loc = ExportLocation $ toInternalGitPath f'
f' = getTopFilePath f
-performUnexport :: Remote -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
-performUnexport r db eks loc = do
- ifM (allM (\ek -> removeExport (exportActions r) (asKey ek) loc) eks)
+performUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
+performUnexport r ea db eks loc = do
+ ifM (allM (\ek -> removeExport ea (asKey ek) loc) eks)
( next $ cleanupUnexport r db eks loc
, stop
)
@@ -269,47 +273,47 @@ cleanupUnexport r db eks loc = do
logChange (asKey ek) (uuid r) InfoMissing
return True
-startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
-startRecoverIncomplete r db sha oldf
+startRecoverIncomplete :: Remote -> ExportActions Annex -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
+startRecoverIncomplete r ea db sha oldf
| sha == nullSha = stop
| otherwise = do
ek <- exportKey sha
let loc@(ExportLocation f) = exportTempName ek
showStart "unexport" f
liftIO $ removeExportLocation db (asKey ek) oldloc
- next $ performUnexport r db [ek] loc
+ next $ performUnexport r ea db [ek] loc
where
oldloc = ExportLocation $ toInternalGitPath oldf'
oldf' = getTopFilePath oldf
-startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
-startMoveToTempName r db f ek = do
+startMoveToTempName :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
+startMoveToTempName r ea db f ek = do
let tmploc@(ExportLocation tmpf) = exportTempName ek
showStart "rename" (f' ++ " -> " ++ tmpf)
- next $ performRename r db ek loc tmploc
+ next $ performRename r ea db ek loc tmploc
where
loc = ExportLocation $ toInternalGitPath f'
f' = getTopFilePath f
-startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
-startMoveFromTempName r db ek f = do
+startMoveFromTempName :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
+startMoveFromTempName r ea db ek f = do
let tmploc@(ExportLocation tmpf) = exportTempName ek
stopUnless (liftIO $ elem tmploc <$> getExportLocation db (asKey ek)) $ do
showStart "rename" (tmpf ++ " -> " ++ f')
- next $ performRename r db ek tmploc loc
+ next $ performRename r ea db ek tmploc loc
where
loc = ExportLocation $ toInternalGitPath f'
f' = getTopFilePath f
-performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
-performRename r db ek src dest = do
- ifM (renameExport (exportActions r) (asKey ek) src dest)
+performRename :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
+performRename r ea db ek src dest = do
+ ifM (renameExport ea (asKey ek) src dest)
( next $ cleanupRename db ek src dest
-- In case the special remote does not support renaming,
-- unexport the src instead.
, do
warning "rename failed; deleting instead"
- performUnexport r db [ek] src
+ performUnexport r ea db [ek] src
)
cleanupRename :: ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup