7c7af82578
Make a pass over the whole exported tree, and upload anything that has not yet reached the export. Update location log when exporting. Note that the synthesized keys for non-annexed files are stored in the location log too. Some cases involving files in the tree with the same content are not handled correctly yet. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
152 lines
4.2 KiB
Haskell
152 lines
4.2 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2017 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.Export where
|
|
|
|
import Command
|
|
import qualified Git
|
|
import qualified Git.DiffTree
|
|
import qualified Git.LsTree
|
|
import Git.Types
|
|
import Git.Sha
|
|
import Git.FilePath
|
|
import Types.Key
|
|
import Types.Remote
|
|
import Annex.Content
|
|
import Annex.CatFile
|
|
import Logs.Location
|
|
import Messages.Progress
|
|
import Utility.Tmp
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
cmd :: Command
|
|
cmd = command "export" SectionCommon
|
|
"export content to a remote"
|
|
paramTreeish (seek <$$> optParser)
|
|
|
|
data ExportOptions = ExportOptions
|
|
{ exportTreeish :: Git.Ref
|
|
, exportRemote :: DeferredParse Remote
|
|
}
|
|
|
|
optParser :: CmdParamsDesc -> Parser ExportOptions
|
|
optParser _ = ExportOptions
|
|
<$> (Git.Ref <$> parsetreeish)
|
|
<*> (parseRemoteOption <$> parseToOption)
|
|
where
|
|
parsetreeish = argument str
|
|
( metavar paramTreeish
|
|
)
|
|
|
|
-- An export includes both annexed files and files stored in git.
|
|
-- For the latter, a SHA1 key is synthesized.
|
|
data ExportKey = AnnexKey Key | GitKey Key
|
|
|
|
asKey :: ExportKey -> Key
|
|
asKey (AnnexKey k) = k
|
|
asKey (GitKey k) = k
|
|
|
|
exportKey :: Git.Sha -> Annex ExportKey
|
|
exportKey sha = mk <$> catKey sha
|
|
where
|
|
mk (Just k) = AnnexKey k
|
|
mk Nothing = GitKey $ Key
|
|
{ keyName = show sha
|
|
, keyVariety = SHA1Key (HasExt False)
|
|
, keySize = Nothing
|
|
, keyMtime = Nothing
|
|
, keyChunkSize = Nothing
|
|
, keyChunkNum = Nothing
|
|
}
|
|
|
|
seek :: ExportOptions -> CommandSeek
|
|
seek o = do
|
|
r <- getParsed (exportRemote o)
|
|
let oldtreeish = emptyTree -- XXX temporary
|
|
|
|
-- First, diff the old and new trees and update all changed
|
|
-- files in the export.
|
|
(diff, cleanup) <- inRepo $
|
|
Git.DiffTree.diffTreeRecursive oldtreeish (exportTreeish o)
|
|
seekActions $ pure $ map (startDiff r) diff
|
|
void $ liftIO cleanup
|
|
|
|
-- In case a previous export was incomplete, make a pass
|
|
-- over the whole tree and export anything that is not
|
|
-- yet exported.
|
|
(l, cleanup') <- inRepo $ Git.LsTree.lsTree (exportTreeish o)
|
|
seekActions $ pure $ map (start r) l
|
|
void $ liftIO cleanup'
|
|
|
|
startDiff :: Remote -> Git.DiffTree.DiffTreeItem -> CommandStart
|
|
startDiff r diff
|
|
| Git.DiffTree.dstsha diff == nullSha = do
|
|
showStart "unexport" f
|
|
oldk <- exportKey (Git.DiffTree.srcsha diff)
|
|
next $ performUnexport r oldk loc
|
|
| otherwise = do
|
|
showStart "export" f
|
|
k <- exportKey (Git.DiffTree.dstsha diff)
|
|
next $ performExport r k (Git.DiffTree.dstsha diff) loc
|
|
where
|
|
loc = ExportLocation $ toInternalGitPath $
|
|
getTopFilePath $ Git.DiffTree.file diff
|
|
f = getTopFilePath $ Git.DiffTree.file diff
|
|
|
|
start :: Remote -> Git.LsTree.TreeItem -> CommandStart
|
|
start r ti = do
|
|
ek <- exportKey (Git.LsTree.sha ti)
|
|
stopUnless (elem (uuid r) <$> loggedLocations (asKey ek)) $
|
|
next $ performExport r ek (Git.LsTree.sha ti) loc
|
|
where
|
|
loc = ExportLocation $ toInternalGitPath $
|
|
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
|
|
|
|
cleanupExport :: Remote -> ExportKey -> CommandCleanup
|
|
cleanupExport r ek = do
|
|
logChange (asKey ek) (uuid r) InfoPresent
|
|
return True
|
|
|
|
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
|
|
|
|
cleanupUnexport :: Remote -> ExportKey -> CommandCleanup
|
|
cleanupUnexport r ek = do
|
|
logChange (asKey ek) (uuid r) InfoMissing
|
|
return True
|