refactor ExportActions

This will allow disabling exports for remotes that are not configured to
allow them. Also, exportSupported will be useful for the external
special remote to probe.

This commit was supported by the NSF-funded DataLad project
This commit is contained in:
Joey Hess 2017-09-01 13:02:07 -04:00
parent 5483ea90ec
commit a4328b49d2
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
20 changed files with 143 additions and 149 deletions

View file

@ -69,6 +69,9 @@ exportKey sha = mk <$> catKey sha
seek :: ExportOptions -> CommandSeek
seek o = do
r <- getParsed (exportRemote o)
unlessM (exportSupported (exportActions r)) $
error "That remote does not support exports."
new <- fromMaybe (error "unknown tree") <$>
-- Dereference the tree pointed to by the branch, commit,
-- or tag.
@ -113,29 +116,28 @@ startExport r ti = do
f = getTopFilePath $ Git.LsTree.file ti
performExport :: Remote -> ExportKey -> Sha -> ExportLocation -> CommandPerform
performExport r ek contentsha loc = case storeExport r of
Nothing -> error "remote does not support exporting files"
Just storer -> do
sent <- case ek of
AnnexKey k -> ifM (inAnnex k)
( metered Nothing k $ \m -> do
let rollback = void $ performUnexport r ek loc
sendAnnex k rollback
(\f -> storer f k loc m)
, do
showNote "not available"
return False
)
-- Sending a non-annexed file.
GitKey sha1k -> metered Nothing sha1k $ \m ->
withTmpFile "export" $ \tmp h -> do
b <- catObject contentsha
liftIO $ L.hPut h b
liftIO $ hClose h
storer tmp sha1k loc m
if sent
then next $ cleanupExport r ek
else stop
performExport r ek contentsha loc = do
let storer = storeExport $ exportActions r
sent <- case ek of
AnnexKey k -> ifM (inAnnex k)
( metered Nothing k $ \m -> do
let rollback = void $ performUnexport r ek loc
sendAnnex k rollback
(\f -> storer f k loc m)
, do
showNote "not available"
return False
)
-- Sending a non-annexed file.
GitKey sha1k -> metered Nothing sha1k $ \m ->
withTmpFile "export" $ \tmp h -> do
b <- catObject contentsha
liftIO $ L.hPut h b
liftIO $ hClose h
storer tmp sha1k loc m
if sent
then next $ cleanupExport r ek
else stop
cleanupExport :: Remote -> ExportKey -> CommandCleanup
cleanupExport r ek = do
@ -154,13 +156,12 @@ startUnexport r diff
f = getTopFilePath $ Git.DiffTree.file diff
performUnexport :: Remote -> ExportKey -> ExportLocation -> CommandPerform
performUnexport r ek loc = case removeExport r of
Nothing -> error "remote does not support removing exported files"
Just remover -> do
ok <- remover (asKey ek) loc
if ok
then next $ cleanupUnexport r ek
else stop
performUnexport r ek loc = do
let remover = removeExport $ exportActions r
ok <- remover (asKey ek) loc
if ok
then next $ cleanupUnexport r ek
else stop
cleanupUnexport :: Remote -> ExportKey -> CommandCleanup
cleanupUnexport r ek = do