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:
parent
5483ea90ec
commit
a4328b49d2
20 changed files with 143 additions and 149 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue