set S3 version id in retrieveExportWithContentIdentifierS3
This is necessary because of checks for a S3 version id being set done when deleting the export or overwriting or renaming it.
This commit is contained in:
parent
b9b3567747
commit
f08cd6a4ac
2 changed files with 39 additions and 42 deletions
|
@ -23,6 +23,7 @@ import Git.Types
|
|||
import Git.Tree
|
||||
import Git.Sha
|
||||
import Git.FilePath
|
||||
import Git.History
|
||||
import qualified Git.Ref
|
||||
import qualified Git.Branch
|
||||
import qualified Annex
|
||||
|
@ -89,10 +90,10 @@ buildImportCommit
|
|||
-> Annex (Maybe Ref)
|
||||
buildImportCommit remote importtreeconfig importcommitconfig importable =
|
||||
case importCommitParent importcommitconfig of
|
||||
Nothing -> go emptyTree Nothing
|
||||
Nothing -> go Nothing
|
||||
Just basecommit -> inRepo (Git.Ref.tree basecommit) >>= \case
|
||||
Nothing -> go emptyTree Nothing
|
||||
Just origtree -> go origtree (Just basecommit)
|
||||
Nothing -> go Nothing
|
||||
Just _ -> go (Just basecommit)
|
||||
where
|
||||
basetree = case importtreeconfig of
|
||||
ImportTree -> emptyTree
|
||||
|
@ -101,29 +102,26 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
|
|||
ImportTree -> Nothing
|
||||
ImportSubTree dir _ -> Just dir
|
||||
|
||||
go origtree basecommit = do
|
||||
go basecommit = do
|
||||
imported@(History finaltree _) <-
|
||||
buildImportTrees basetree subdir importable
|
||||
mkcommits origtree basecommit imported >>= \case
|
||||
Nothing -> return Nothing
|
||||
Just finalcommit -> do
|
||||
skipOldHistory basecommit imported >>= \case
|
||||
Just toadd -> do
|
||||
finalcommit <- mkcommits basecommit toadd
|
||||
updatestate finaltree
|
||||
return (Just finalcommit)
|
||||
Nothing -> return Nothing
|
||||
|
||||
mkcommits origtree basecommit (History importedtree hs) = do
|
||||
parents <- catMaybes <$> mapM (mkcommits origtree basecommit) (S.toList hs)
|
||||
if importedtree == origtree && null parents
|
||||
then return Nothing -- no changes to commit
|
||||
else do
|
||||
let commitparents = if null parents
|
||||
then catMaybes [basecommit]
|
||||
else parents
|
||||
commit <- inRepo $ Git.Branch.commitTree
|
||||
(importCommitMode importcommitconfig)
|
||||
(importCommitMessage importcommitconfig)
|
||||
commitparents
|
||||
importedtree
|
||||
return (Just commit)
|
||||
mkcommits basecommit (History importedtree hs) = do
|
||||
parents <- mapM (mkcommits basecommit) (S.toList hs)
|
||||
let commitparents = if null parents
|
||||
then catMaybes [basecommit]
|
||||
else parents
|
||||
inRepo $ Git.Branch.commitTree
|
||||
(importCommitMode importcommitconfig)
|
||||
(importCommitMessage importcommitconfig)
|
||||
commitparents
|
||||
importedtree
|
||||
|
||||
updatestate committedtree = do
|
||||
importedtree <- case subdir of
|
||||
|
@ -136,7 +134,7 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
|
|||
updateexportdb importedtree
|
||||
oldexport <- updateexportlog importedtree
|
||||
updatelocationlog oldexport importedtree
|
||||
|
||||
|
||||
updateexportdb importedtree = do
|
||||
db <- Export.openDb (Remote.uuid remote)
|
||||
Export.writeLockDbWhile db $ do
|
||||
|
@ -176,24 +174,6 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
|
|||
Export.runExportDiffUpdater updater db oldtree finaltree
|
||||
Export.closeDb db
|
||||
|
||||
data History t = History t (S.Set (History t))
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
historyDepth :: History t -> Integer
|
||||
historyDepth (History _ s)
|
||||
| S.null s = 1
|
||||
| otherwise = 1 + maximum (map historyDepth (S.toList s))
|
||||
|
||||
truncateHistoryToDepth :: Ord t => Integer -> History t -> History t
|
||||
truncateHistoryToDepth n (History t s) = History t (go 1 s)
|
||||
where
|
||||
go depth s
|
||||
| depth >= n = S.empty
|
||||
| otherwise =
|
||||
let depth' = succ depth
|
||||
in flip S.map s $ \(History t' s') ->
|
||||
History t' (go depth' s')
|
||||
|
||||
{- Finds the part of the History of git trees that is new and should be
|
||||
- committed on top of the basecommit, skipping parts that have
|
||||
- already been committed.
|
||||
|
@ -209,7 +189,11 @@ truncateHistoryToDepth n (History t s) = History t (go 1 s)
|
|||
- basecommit.
|
||||
-}
|
||||
skipOldHistory :: Maybe Sha -> History Sha -> Annex (Maybe (History Sha))
|
||||
skipOldHistory basecommit importedhistory = undefined
|
||||
skipOldHistory Nothing importedhistory = return (Just importedhistory)
|
||||
skipOldHistory (Just basecommit) importedhistory =
|
||||
inRepo (getTreeHistoryToDepth (historyDepth importedhistory) basecommit) >>= \case
|
||||
Just knownhistory -> return $ skipOldHistory' knownhistory importedhistory
|
||||
Nothing -> return $ Just importedhistory
|
||||
|
||||
{- The knownhistory does not need to be complete; it can be
|
||||
- truncated to the same depth as the importedhistory to avoid reading
|
||||
|
|
15
Remote/S3.hs
15
Remote/S3.hs
|
@ -555,7 +555,12 @@ retrieveExportWithContentIdentifierS3 hv r info loc cid dest mkkey p = withS3Han
|
|||
rewritePreconditionException $ retrieveHelper' h dest p $
|
||||
limitGetToContentIdentifier cid $
|
||||
S3.getObject (bucket info) o
|
||||
mkkey
|
||||
mk <- mkkey
|
||||
case (mk, extractContentIdentifier cid o) of
|
||||
(Just k, Right vid) ->
|
||||
setS3VersionID info (uuid r) k vid
|
||||
_ -> noop
|
||||
return mk
|
||||
where
|
||||
o = T.pack $ bucketExportLocation info loc
|
||||
|
||||
|
@ -1089,6 +1094,14 @@ limitToContentIdentifier (ContentIdentifier v) limitetag limitversionid =
|
|||
in limitetag (Just etag)
|
||||
_ -> limitversionid (Just t)
|
||||
|
||||
-- A ContentIdentifier contains either a etag or a S3 version id.
|
||||
extractContentIdentifier :: ContentIdentifier -> S3.Object -> Either S3Etag (Maybe S3VersionID)
|
||||
extractContentIdentifier (ContentIdentifier v) o =
|
||||
let t = either mempty id (T.decodeUtf8' v)
|
||||
in case T.take 1 t of
|
||||
"#" -> Left (T.drop 1 t)
|
||||
_ -> Right (mkS3VersionID o (Just t))
|
||||
|
||||
setS3VersionID :: S3Info -> UUID -> Key -> Maybe S3VersionID -> Annex ()
|
||||
setS3VersionID info u k vid
|
||||
| versioning info = maybe noop (setS3VersionID' u k) vid
|
||||
|
|
Loading…
Add table
Reference in a new issue