git-remote-annex: incremental pushing
Untested Sponsored-by: Joshua Antonishen on Patreon
This commit is contained in:
parent
f2d17cf154
commit
3039331529
2 changed files with 128 additions and 27 deletions
|
@ -226,8 +226,7 @@ push st rmt ls = do
|
||||||
| otherwise -> ifM (isfastforward srcref tr)
|
| otherwise -> ifM (isfastforward srcref tr)
|
||||||
( okresp $
|
( okresp $
|
||||||
M.insert tr srcref trackingrefs
|
M.insert tr srcref trackingrefs
|
||||||
, errresp $ fromRef' (dstRef r)
|
, errresp "non-fast-forward"
|
||||||
<> " non-fast-forward"
|
|
||||||
)
|
)
|
||||||
Nothing -> okresp $ M.delete tr trackingrefs
|
Nothing -> okresp $ M.delete tr trackingrefs
|
||||||
|
|
||||||
|
@ -237,8 +236,8 @@ push st rmt ls = do
|
||||||
-- before git push checks that, it actually tells us to push.
|
-- before git push checks that, it actually tells us to push.
|
||||||
-- That seems likely to be a bug in git, and this is a workaround.
|
-- That seems likely to be a bug in git, and this is a workaround.
|
||||||
isfastforward newref tr = case M.lookup tr (trackingRefs st) of
|
isfastforward newref tr = case M.lookup tr (trackingRefs st) of
|
||||||
Nothing -> pure False
|
|
||||||
Just prevsha -> inRepo $ Git.Ref.isAncestor prevsha newref
|
Just prevsha -> inRepo $ Git.Ref.isAncestor prevsha newref
|
||||||
|
Nothing -> pure True
|
||||||
|
|
||||||
-- Send responses followed by newline to indicate end of push.
|
-- Send responses followed by newline to indicate end of push.
|
||||||
sendresponses responses = liftIO $ do
|
sendresponses responses = liftIO $ do
|
||||||
|
@ -260,24 +259,92 @@ push st rmt ls = do
|
||||||
-- manifest, which will appear as if all tracking branches were deleted
|
-- manifest, which will appear as if all tracking branches were deleted
|
||||||
-- from it.
|
-- from it.
|
||||||
fullPush :: State -> Remote -> [Ref] -> Annex (Bool, State)
|
fullPush :: State -> Remote -> [Ref] -> Annex (Bool, State)
|
||||||
fullPush st rmt refs = flip catchNonAsync failed $ do
|
fullPush st rmt refs = guardPush st $ do
|
||||||
oldmanifest <- maybe (downloadManifest rmt) pure (manifestCache st)
|
oldmanifest <- maybe (downloadManifest rmt) pure (manifestCache st)
|
||||||
bundlekey <- generateAndUploadGitBundle rmt refs oldmanifest
|
let bs = map Git.Bundle.fullBundleSpec refs
|
||||||
|
bundlekey <- generateAndUploadGitBundle rmt bs oldmanifest
|
||||||
uploadManifest rmt (Manifest [bundlekey])
|
uploadManifest rmt (Manifest [bundlekey])
|
||||||
let st' = st { manifestCache = Nothing }
|
|
||||||
ok <- allM (dropKey rmt) $
|
ok <- allM (dropKey rmt) $
|
||||||
filter (/= bundlekey) (inManifest oldmanifest)
|
filter (/= bundlekey) (inManifest oldmanifest)
|
||||||
return (ok, st')
|
return (ok, st { manifestCache = Nothing })
|
||||||
where
|
|
||||||
failed ex = do
|
guardPush :: State -> Annex (Bool, State) -> Annex (Bool, State)
|
||||||
liftIO $ hPutStrLn stderr $
|
guardPush st a = catchNonAsync a $ \ex -> do
|
||||||
"Push faild (" ++ show ex ++ ")"
|
liftIO $ hPutStrLn stderr $
|
||||||
return (False, st)
|
"Push faild (" ++ show ex ++ ")"
|
||||||
|
return (False, st { manifestCache = Nothing })
|
||||||
|
|
||||||
-- Incremental push of only the refs that changed.
|
-- Incremental push of only the refs that changed.
|
||||||
|
--
|
||||||
|
-- No refs were deleted (that causes a fullPush), but new refs may
|
||||||
|
-- have been added.
|
||||||
incrementalPush :: State -> Remote -> M.Map Ref Sha -> M.Map Ref Sha -> Annex (Bool, State)
|
incrementalPush :: State -> Remote -> M.Map Ref Sha -> M.Map Ref Sha -> Annex (Bool, State)
|
||||||
incrementalPush st rmt oldtrackingrefs newtrackingrefs = do
|
incrementalPush st rmt oldtrackingrefs newtrackingrefs = guardPush st $ do
|
||||||
error "TODO incrementalPush"
|
bs <- calc [] (M.toList newtrackingrefs)
|
||||||
|
liftIO $ hPutStrLn stderr (show bs)
|
||||||
|
oldmanifest <- maybe (downloadManifest rmt) pure (manifestCache st)
|
||||||
|
bundlekey <- generateAndUploadGitBundle rmt bs oldmanifest
|
||||||
|
uploadManifest rmt (Manifest [bundlekey])
|
||||||
|
return (True, st { manifestCache = Nothing })
|
||||||
|
where
|
||||||
|
calc c [] = return (reverse c)
|
||||||
|
calc c ((ref, sha):refs) = case M.lookup ref oldtrackingrefs of
|
||||||
|
Just oldsha
|
||||||
|
| oldsha == sha -> calc c refs -- unchanged
|
||||||
|
| otherwise ->
|
||||||
|
ifM (inRepo $ Git.Ref.isAncestor oldsha ref)
|
||||||
|
( use $ checkprereq oldsha ref
|
||||||
|
, use $ findotherprereq ref sha
|
||||||
|
)
|
||||||
|
Nothing -> use $ findotherprereq ref sha
|
||||||
|
where
|
||||||
|
use a = do
|
||||||
|
bs <- a
|
||||||
|
calc (bs:c) refs
|
||||||
|
|
||||||
|
-- Unfortunately, git bundle will let a prerequisite specified
|
||||||
|
-- for one ref prevent it including another ref. For example,
|
||||||
|
-- where x is a ref that points at A, and y is a ref that points at
|
||||||
|
-- B (which has A as its parent), git bundle x A..y
|
||||||
|
-- will omit including the x ref in the bundle at all.
|
||||||
|
--
|
||||||
|
-- But we need to include all (changed) refs that the user
|
||||||
|
-- specified to push in the bundle. So, only include the sha
|
||||||
|
-- as a prerequisite when it will not prevent including another
|
||||||
|
-- changed ref in the bundle.
|
||||||
|
checkprereq prereq ref =
|
||||||
|
ifM (anyM shadows $ M.elems $ M.delete ref changedrefs)
|
||||||
|
( pure $ Git.Bundle.fullBundleSpec ref
|
||||||
|
, pure $ Git.Bundle.BundleSpec
|
||||||
|
{ Git.Bundle.preRequisiteRef = Just prereq
|
||||||
|
, Git.Bundle.includeRef = ref
|
||||||
|
}
|
||||||
|
)
|
||||||
|
where
|
||||||
|
shadows s
|
||||||
|
| s == prereq = pure True
|
||||||
|
| otherwise = inRepo $ Git.Ref.isAncestor s prereq
|
||||||
|
changedrefs = M.differenceWith
|
||||||
|
(\a b -> if a == b then Nothing else Just a)
|
||||||
|
newtrackingrefs oldtrackingrefs
|
||||||
|
|
||||||
|
-- When the old tracking ref is not able to be used as a
|
||||||
|
-- prerequisite, this to find some other ref that was previously
|
||||||
|
-- pushed that can be used as a prerequisite instead. This can
|
||||||
|
-- optimise the bundle size a bit in edge cases.
|
||||||
|
--
|
||||||
|
-- For example, a forced push of branch foo that resets it back
|
||||||
|
-- several commits can use a previously pushed bar as a prerequisite
|
||||||
|
-- if it's an ancestor of foo.
|
||||||
|
findotherprereq ref sha =
|
||||||
|
findotherprereq' ref sha (M.elems oldtrackingrefs)
|
||||||
|
findotherprereq' ref _ [] = pure (Git.Bundle.fullBundleSpec ref)
|
||||||
|
findotherprereq' ref sha (l:ls)
|
||||||
|
| l == sha = findotherprereq' ref sha ls
|
||||||
|
| otherwise = ifM (inRepo $ Git.Ref.isAncestor l ref)
|
||||||
|
( checkprereq l ref
|
||||||
|
, findotherprereq' ref sha ls
|
||||||
|
)
|
||||||
|
|
||||||
-- When the push deletes all refs from the remote, drop the manifest
|
-- When the push deletes all refs from the remote, drop the manifest
|
||||||
-- and all bundles that were listed in it. The manifest is dropped
|
-- and all bundles that were listed in it. The manifest is dropped
|
||||||
|
@ -506,7 +573,7 @@ downloadManifest rmt = ifM (Remote.checkPresent rmt mk)
|
||||||
-- Note that if this is interrupted or loses access to the remote part
|
-- Note that if this is interrupted or loses access to the remote part
|
||||||
-- way through, it may leave the remote without a manifest file. That will
|
-- way through, it may leave the remote without a manifest file. That will
|
||||||
-- appear as if all refs have been deleted from the remote.
|
-- appear as if all refs have been deleted from the remote.
|
||||||
-- FIXME It should be possible to remember when that happened, by writing
|
-- XXX It should be possible to remember when that happened, by writing
|
||||||
-- state to a file before, and then the next time git-remote-annex is run, it
|
-- state to a file before, and then the next time git-remote-annex is run, it
|
||||||
-- could recover from the situation.
|
-- could recover from the situation.
|
||||||
uploadManifest :: Remote -> Manifest -> Annex ()
|
uploadManifest :: Remote -> Manifest -> Annex ()
|
||||||
|
@ -571,19 +638,23 @@ uploadGitBundle rmt k =
|
||||||
unlessM (upload rmt k (AssociatedFile Nothing) stdRetry noNotification) $
|
unlessM (upload rmt k (AssociatedFile Nothing) stdRetry noNotification) $
|
||||||
giveup $ "Failed to upload " ++ serializeKey k
|
giveup $ "Failed to upload " ++ serializeKey k
|
||||||
|
|
||||||
-- Generates a git bundle that contains the specified refs, ingests
|
-- Generates a git bundle, ingests it into the local objects directory,
|
||||||
-- it into the local objects directory, and uploads its key to the special
|
-- and uploads its key to the special remote.
|
||||||
-- remote.
|
|
||||||
--
|
--
|
||||||
-- If the key is present in the provided manifest, avoids uploading it.
|
-- If the key is already present in the provided manifest, avoids
|
||||||
|
-- uploading it.
|
||||||
--
|
--
|
||||||
-- On failure, an exception is thrown, and nothing is added to the local
|
-- On failure, an exception is thrown, and nothing is added to the local
|
||||||
-- objects directory.
|
-- objects directory.
|
||||||
generateAndUploadGitBundle :: Remote -> [Ref] -> Manifest -> Annex Key
|
generateAndUploadGitBundle
|
||||||
generateAndUploadGitBundle rmt refs manifest =
|
:: Remote
|
||||||
|
-> [Git.Bundle.BundleSpec]
|
||||||
|
-> Manifest
|
||||||
|
-> Annex Key
|
||||||
|
generateAndUploadGitBundle rmt bs manifest =
|
||||||
withTmpFile "GITBUNDLE" $ \tmp tmph -> do
|
withTmpFile "GITBUNDLE" $ \tmp tmph -> do
|
||||||
liftIO $ hClose tmph
|
liftIO $ hClose tmph
|
||||||
inRepo $ Git.Bundle.create tmp refs
|
inRepo $ Git.Bundle.create tmp bs
|
||||||
bundlekey <- genGitBundleKey (Remote.uuid rmt)
|
bundlekey <- genGitBundleKey (Remote.uuid rmt)
|
||||||
(toRawFilePath tmp) nullMeterUpdate
|
(toRawFilePath tmp) nullMeterUpdate
|
||||||
unless (bundlekey `elem` (inManifest manifest)) $ do
|
unless (bundlekey `elem` (inManifest manifest)) $ do
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Git.Bundle where
|
module Git.Bundle where
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
|
@ -24,15 +26,43 @@ listHeads bundle repo = map gen . S8.lines <$>
|
||||||
unbundle :: FilePath -> Repo -> IO ()
|
unbundle :: FilePath -> Repo -> IO ()
|
||||||
unbundle bundle = runQuiet [Param "bundle", Param "unbundle", File bundle]
|
unbundle bundle = runQuiet [Param "bundle", Param "unbundle", File bundle]
|
||||||
|
|
||||||
create :: FilePath -> [Ref] -> Repo -> IO ()
|
-- Specifies what to include in the bundle.
|
||||||
create bundle refs repo = pipeWrite
|
data BundleSpec = BundleSpec
|
||||||
|
{ preRequisiteRef :: Maybe Ref
|
||||||
|
-- ^ Do not include this Ref, or any objects reachable from it
|
||||||
|
-- in the bundle. This should be an ancestor of the includeRef.
|
||||||
|
, includeRef :: Ref
|
||||||
|
-- ^ Include this Ref and objects reachable from it in the bundle,
|
||||||
|
-- unless filtered out by the preRequisiteRef of this BundleSpec
|
||||||
|
-- or any other one that is included in the bundle.
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
-- Include the ref and all objects reachable from it in the bundle.
|
||||||
|
-- (Unless another BundleSpec is included that has a preRequisiteRef
|
||||||
|
-- that filters out the ref or other objects.)
|
||||||
|
fullBundleSpec :: Ref -> BundleSpec
|
||||||
|
fullBundleSpec r = BundleSpec
|
||||||
|
{ preRequisiteRef = Nothing
|
||||||
|
, includeRef = r
|
||||||
|
}
|
||||||
|
|
||||||
|
create :: FilePath -> [BundleSpec] -> Repo -> IO ()
|
||||||
|
create bundle revs repo = pipeWrite
|
||||||
[ Param "bundle"
|
[ Param "bundle"
|
||||||
, Param "create"
|
, Param "create"
|
||||||
, Param "--quiet"
|
, Param "--quiet"
|
||||||
, File bundle
|
, File bundle
|
||||||
, Param "--stdin"
|
, Param "--stdin"
|
||||||
] repo writerefs
|
] repo writer
|
||||||
where
|
where
|
||||||
writerefs h = do
|
writer h = do
|
||||||
mapM_ (S8.hPutStrLn h . fromRef') refs
|
forM_ revs $ \bs ->
|
||||||
|
case preRequisiteRef bs of
|
||||||
|
Nothing -> S8.hPutStrLn h $
|
||||||
|
fromRef' (includeRef bs)
|
||||||
|
Just pr -> S8.hPutStrLn h $
|
||||||
|
fromRef' pr
|
||||||
|
<> ".." <>
|
||||||
|
fromRef' (includeRef bs)
|
||||||
hClose h
|
hClose h
|
||||||
|
|
Loading…
Reference in a new issue