2011-12-10 00:27:22 +00:00
|
|
|
{- git-annex command
|
|
|
|
-
|
2011-12-30 20:24:30 +00:00
|
|
|
- Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2011-2014 Joey Hess <id@joeyh.name>
|
2011-12-10 00:27:22 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2014-12-29 17:41:03 +00:00
|
|
|
module Command.Sync (
|
|
|
|
cmd,
|
|
|
|
prepMerge,
|
|
|
|
mergeLocal,
|
|
|
|
mergeRemote,
|
|
|
|
commitStaged,
|
2015-02-11 17:33:55 +00:00
|
|
|
commitMsg,
|
2014-12-29 17:41:03 +00:00
|
|
|
pushBranch,
|
|
|
|
updateBranch,
|
|
|
|
syncBranch,
|
|
|
|
updateSyncBranch,
|
|
|
|
) where
|
2011-12-10 00:27:22 +00:00
|
|
|
|
|
|
|
import Common.Annex
|
|
|
|
import Command
|
2011-12-31 01:17:36 +00:00
|
|
|
import qualified Annex
|
2011-12-10 00:27:22 +00:00
|
|
|
import qualified Annex.Branch
|
2014-01-19 21:35:36 +00:00
|
|
|
import qualified Remote
|
|
|
|
import qualified Types.Remote as Remote
|
2012-12-12 23:20:38 +00:00
|
|
|
import Annex.Direct
|
2014-03-02 22:01:07 +00:00
|
|
|
import Annex.Hook
|
2011-12-14 19:56:11 +00:00
|
|
|
import qualified Git.Command
|
2012-06-27 17:08:32 +00:00
|
|
|
import qualified Git.LsFiles as LsFiles
|
2011-12-30 22:04:01 +00:00
|
|
|
import qualified Git.Branch
|
2015-01-07 02:23:04 +00:00
|
|
|
import qualified Git.Types as Git
|
2011-12-15 22:11:42 +00:00
|
|
|
import qualified Git.Ref
|
|
|
|
import qualified Git
|
2011-12-31 07:27:37 +00:00
|
|
|
import qualified Remote.Git
|
2012-10-11 22:39:21 +00:00
|
|
|
import Config
|
2014-01-19 21:35:36 +00:00
|
|
|
import Annex.Wanted
|
|
|
|
import Annex.Content
|
|
|
|
import Command.Get (getKeyFile')
|
2014-02-02 23:57:22 +00:00
|
|
|
import qualified Command.Move
|
2014-01-19 21:35:36 +00:00
|
|
|
import Logs.Location
|
|
|
|
import Annex.Drop
|
2014-02-03 02:46:55 +00:00
|
|
|
import Annex.UUID
|
2015-02-11 17:33:55 +00:00
|
|
|
import Logs.UUID
|
2014-03-04 20:26:15 +00:00
|
|
|
import Annex.AutoMerge
|
2014-04-12 19:59:34 +00:00
|
|
|
import Annex.Ssh
|
2015-06-16 22:38:12 +00:00
|
|
|
import Annex.BloomFilter
|
2015-06-16 21:58:15 +00:00
|
|
|
import Utility.Bloom
|
2015-08-20 21:18:21 +00:00
|
|
|
import Utility.OptParse
|
2011-12-10 00:27:22 +00:00
|
|
|
|
2013-10-17 17:34:27 +00:00
|
|
|
import Control.Concurrent.MVar
|
2015-02-11 17:33:55 +00:00
|
|
|
import qualified Data.Map as M
|
2011-12-10 00:27:22 +00:00
|
|
|
|
2015-07-08 16:33:27 +00:00
|
|
|
cmd :: Command
|
2015-08-14 17:49:55 +00:00
|
|
|
cmd = withGlobalOptions [jobsOption] $
|
|
|
|
command "sync" SectionCommon
|
|
|
|
"synchronize local repository with remotes"
|
|
|
|
(paramRepeating paramRemote) (seek <$$> optParser)
|
2015-07-09 23:03:21 +00:00
|
|
|
|
|
|
|
data SyncOptions = SyncOptions
|
|
|
|
{ syncWith :: CmdParams
|
2015-09-13 17:15:35 +00:00
|
|
|
, commitOption :: Bool
|
2015-07-09 23:03:21 +00:00
|
|
|
, messageOption :: Maybe String
|
2015-09-13 17:15:35 +00:00
|
|
|
, pullOption :: Bool
|
|
|
|
, pushOption :: Bool
|
|
|
|
, contentOption :: Bool
|
2015-07-09 23:03:21 +00:00
|
|
|
, keyOptions :: Maybe KeyOptions
|
|
|
|
}
|
|
|
|
|
|
|
|
optParser :: CmdParamsDesc -> Parser SyncOptions
|
|
|
|
optParser desc = SyncOptions
|
2015-09-14 17:19:04 +00:00
|
|
|
<$> (many $ argument str
|
|
|
|
( metavar desc
|
|
|
|
<> completeRemotes
|
|
|
|
))
|
2015-09-13 17:15:35 +00:00
|
|
|
<*> invertableSwitch "commit" True
|
|
|
|
( help "avoid git commit"
|
2015-07-09 23:03:21 +00:00
|
|
|
)
|
|
|
|
<*> optional (strOption
|
|
|
|
( long "message" <> short 'm' <> metavar "MSG"
|
|
|
|
<> help "commit message"
|
|
|
|
))
|
2015-09-13 17:15:35 +00:00
|
|
|
<*> invertableSwitch "pull" True
|
|
|
|
( help "avoid git pulls from remotes"
|
|
|
|
)
|
|
|
|
<*> invertableSwitch "push" True
|
|
|
|
( help "avoid git pushes to remotes"
|
|
|
|
)
|
|
|
|
<*> invertableSwitch "content" False
|
|
|
|
( help "also transfer file contents"
|
|
|
|
)
|
2015-07-09 23:03:21 +00:00
|
|
|
<*> optional parseAllOption
|
|
|
|
|
|
|
|
seek :: SyncOptions -> CommandSeek
|
|
|
|
seek o = do
|
2013-09-13 18:55:55 +00:00
|
|
|
prepMerge
|
2013-10-17 17:34:27 +00:00
|
|
|
|
|
|
|
-- There may not be a branch checked out until after the commit,
|
2015-03-04 18:44:11 +00:00
|
|
|
-- or perhaps after it gets merged from the remote, or perhaps
|
|
|
|
-- never.
|
|
|
|
-- So only look it up once it's needed, and once there is a
|
2013-11-02 19:29:38 +00:00
|
|
|
-- branch, cache it.
|
2013-10-17 17:34:27 +00:00
|
|
|
mvar <- liftIO newEmptyMVar
|
|
|
|
let getbranch = ifM (liftIO $ isEmptyMVar mvar)
|
|
|
|
( do
|
2013-11-02 19:29:38 +00:00
|
|
|
branch <- inRepo Git.Branch.current
|
|
|
|
when (isJust branch) $
|
|
|
|
liftIO $ putMVar mvar branch
|
2013-10-17 17:34:27 +00:00
|
|
|
return branch
|
|
|
|
, liftIO $ readMVar mvar
|
|
|
|
)
|
|
|
|
let withbranch a = a =<< getbranch
|
|
|
|
|
2015-07-09 23:03:21 +00:00
|
|
|
remotes <- syncRemotes (syncWith o)
|
2014-01-19 21:35:36 +00:00
|
|
|
let gitremotes = filter Remote.gitSyncableRemote remotes
|
2014-02-01 14:33:55 +00:00
|
|
|
let dataremotes = filter (not . remoteAnnexIgnore . Remote.gitconfig) remotes
|
2014-01-19 21:35:36 +00:00
|
|
|
|
fix inversion of control in CommandSeek (no behavior changes)
I've been disliking how the command seek actions were written for some
time, with their inversion of control and ugly workarounds.
The last straw to fix it was sync --content, which didn't fit the
Annex [CommandStart] interface well at all. I have not yet made it take
advantage of the changed interface though.
The crucial change, and probably why I didn't do it this way from the
beginning, is to make each CommandStart action be run with exceptions
caught, and if it fails, increment a failure counter in annex state.
So I finally remove the very first code I wrote for git-annex, which
was before I had exception handling in the Annex monad, and so ran outside
that monad, passing state explicitly as it ran each CommandStart action.
This was a real slog from 1 to 5 am.
Test suite passes.
Memory usage is lower than before, sometimes by a couple of megabytes, and
remains constant, even when running in a large repo, and even when
repeatedly failing and incrementing the error counter. So no accidental
laziness space leaks.
Wall clock speed is identical, even in large repos.
This commit was sponsored by an anonymous bitcoiner.
2014-01-20 08:11:42 +00:00
|
|
|
-- Syncing involves many actions, any of which can independently
|
|
|
|
-- fail, without preventing the others from running.
|
2015-08-14 17:49:55 +00:00
|
|
|
-- These actions cannot be run concurrently.
|
|
|
|
mapM_ includeCommandAction $ concat
|
2015-07-09 23:03:21 +00:00
|
|
|
[ [ commit o ]
|
2014-01-20 17:31:03 +00:00
|
|
|
, [ withbranch mergeLocal ]
|
2015-09-13 17:15:35 +00:00
|
|
|
, map (withbranch . pullRemote o) gitremotes
|
2014-01-20 17:31:03 +00:00
|
|
|
, [ mergeAnnex ]
|
|
|
|
]
|
2015-07-09 23:03:21 +00:00
|
|
|
when (contentOption o) $
|
|
|
|
whenM (seekSyncContent o dataremotes) $
|
2014-02-01 14:49:50 +00:00
|
|
|
-- Transferring content can take a while,
|
|
|
|
-- and other changes can be pushed to the git-annex
|
|
|
|
-- branch on the remotes in the meantime, so pull
|
|
|
|
-- and merge again to avoid our push overwriting
|
|
|
|
-- those changes.
|
2015-08-14 17:49:55 +00:00
|
|
|
mapM_ includeCommandAction $ concat
|
2015-09-13 17:15:35 +00:00
|
|
|
[ map (withbranch . pullRemote o) gitremotes
|
2014-02-01 14:49:50 +00:00
|
|
|
, [ commitAnnex, mergeAnnex ]
|
|
|
|
]
|
2015-08-14 17:49:55 +00:00
|
|
|
|
|
|
|
void $ includeCommandAction $ withbranch pushLocal
|
|
|
|
-- Pushes to remotes can run concurrently.
|
2015-09-13 17:15:35 +00:00
|
|
|
mapM_ (commandAction . withbranch . pushRemote o) gitremotes
|
2011-12-30 20:24:30 +00:00
|
|
|
|
2013-09-13 18:55:55 +00:00
|
|
|
{- Merging may delete the current directory, so go to the top
|
2014-01-19 21:35:36 +00:00
|
|
|
- of the repo. This also means that sync always acts on all files in the
|
|
|
|
- repository, not just on a subdirectory. -}
|
2013-09-13 18:55:55 +00:00
|
|
|
prepMerge :: Annex ()
|
2015-01-07 02:23:04 +00:00
|
|
|
prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath
|
2013-09-13 18:55:55 +00:00
|
|
|
|
2011-12-30 23:11:22 +00:00
|
|
|
syncBranch :: Git.Ref -> Git.Ref
|
work around lack of receive.denyCurrentBranch in direct mode
Now that direct mode sets core.bare=true, git's normal prohibition about
pushing into the currently checked out branch doesn't work.
A simple fix for this would be an update hook which blocks the pushes..
but git hooks must be executable, and git-annex needs to be usable on eg,
FAT, which lacks x bits.
Instead, enabling direct mode switches the branch (eg master) to a special
purpose branch (eg annex/direct/master). This branch is not pushed when
syncing; instead any changes that git annex sync commits get written to
master, and it's pushed (along with synced/master) to the remote.
Note that initialization has been changed to always call setDirect,
even if it's just setDirect False for indirect mode. This is needed because
if the user has just cloned a direct mode repo, that nothing has synced
with before, it may have no master branch, and only a annex/direct/master.
Resulting in that branch being checked out locally too. Calling setDirect False
for indirect mode moves back out of this branch, to a new master branch,
and ensures that a manual "git push" doesn't push changes directly to
the annex/direct/master of the remote. (It's possible that the user
makes a commit w/o using git-annex and pushes it, but nothing I can do
about that really.)
This commit was sponsored by Jonathan Harrington.
2013-11-06 01:08:31 +00:00
|
|
|
syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch
|
2011-12-29 17:37:30 +00:00
|
|
|
|
2011-12-31 08:11:39 +00:00
|
|
|
remoteBranch :: Remote -> Git.Ref -> Git.Ref
|
work around lack of receive.denyCurrentBranch in direct mode
Now that direct mode sets core.bare=true, git's normal prohibition about
pushing into the currently checked out branch doesn't work.
A simple fix for this would be an update hook which blocks the pushes..
but git hooks must be executable, and git-annex needs to be usable on eg,
FAT, which lacks x bits.
Instead, enabling direct mode switches the branch (eg master) to a special
purpose branch (eg annex/direct/master). This branch is not pushed when
syncing; instead any changes that git annex sync commits get written to
master, and it's pushed (along with synced/master) to the remote.
Note that initialization has been changed to always call setDirect,
even if it's just setDirect False for indirect mode. This is needed because
if the user has just cloned a direct mode repo, that nothing has synced
with before, it may have no master branch, and only a annex/direct/master.
Resulting in that branch being checked out locally too. Calling setDirect False
for indirect mode moves back out of this branch, to a new master branch,
and ensures that a manual "git push" doesn't push changes directly to
the annex/direct/master of the remote. (It's possible that the user
makes a commit w/o using git-annex and pushes it, but nothing I can do
about that really.)
This commit was sponsored by Jonathan Harrington.
2013-11-06 01:08:31 +00:00
|
|
|
remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
|
2011-12-31 07:01:18 +00:00
|
|
|
|
2011-12-31 08:11:39 +00:00
|
|
|
syncRemotes :: [String] -> Annex [Remote]
|
2015-08-05 17:49:54 +00:00
|
|
|
syncRemotes ps = do
|
|
|
|
-- Get remote list first, doing automatic initialization
|
|
|
|
-- of remotes when possible.
|
|
|
|
syncRemotes' ps =<< Remote.remoteList' True
|
|
|
|
|
|
|
|
syncRemotes' :: [String] -> [Remote] -> Annex [Remote]
|
|
|
|
syncRemotes' ps remotelist = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2015-08-05 17:49:54 +00:00
|
|
|
pickfast = (++) <$> listed <*> (filterM good (fastest available))
|
2014-12-29 17:41:03 +00:00
|
|
|
|
2012-11-12 05:05:04 +00:00
|
|
|
wanted
|
2015-08-05 17:49:54 +00:00
|
|
|
| null ps = filterM good (concat $ Remote.byCost available)
|
2012-11-12 05:05:04 +00:00
|
|
|
| otherwise = listed
|
2014-12-29 17:41:03 +00:00
|
|
|
|
2015-08-05 17:49:54 +00:00
|
|
|
listed = concat <$> mapM Remote.byNameOrGroup ps
|
2014-12-29 17:41:03 +00:00
|
|
|
|
2014-04-12 19:59:34 +00:00
|
|
|
available = filter (remoteAnnexSync . Remote.gitconfig)
|
2015-08-05 17:49:54 +00:00
|
|
|
$ filter (not . Remote.isXMPPRemote) remotelist
|
2014-12-29 17:41:03 +00:00
|
|
|
|
2014-01-19 21:35:36 +00:00
|
|
|
good r
|
2014-04-12 19:59:34 +00:00
|
|
|
| Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Remote.repo r
|
2014-01-19 21:35:36 +00:00
|
|
|
| otherwise = return True
|
2014-12-29 17:41:03 +00:00
|
|
|
|
2012-11-12 05:05:04 +00:00
|
|
|
fastest = fromMaybe [] . headMaybe . Remote.byCost
|
2011-12-10 00:27:22 +00:00
|
|
|
|
2015-07-09 23:03:21 +00:00
|
|
|
commit :: SyncOptions -> CommandStart
|
2015-09-13 17:15:35 +00:00
|
|
|
commit o = stopUnless shouldcommit $ next $ next $ do
|
|
|
|
commitmessage <- maybe commitMsg return (messageOption o)
|
|
|
|
showStart "commit" ""
|
|
|
|
Annex.Branch.commit "update"
|
|
|
|
ifM isDirect
|
|
|
|
( do
|
|
|
|
void stageDirect
|
|
|
|
void preCommitDirect
|
|
|
|
commitStaged Git.Branch.ManualCommit commitmessage
|
|
|
|
, do
|
|
|
|
inRepo $ Git.Branch.commitQuiet Git.Branch.ManualCommit
|
|
|
|
[ Param "-a"
|
|
|
|
, Param "-m"
|
|
|
|
, Param commitmessage
|
|
|
|
]
|
|
|
|
return True
|
|
|
|
)
|
2015-07-07 20:36:11 +00:00
|
|
|
where
|
2015-09-13 17:15:35 +00:00
|
|
|
shouldcommit = pure (commitOption o)
|
|
|
|
<&&> (annexAutoCommit <$> Annex.getGitConfig)
|
2013-12-01 17:59:39 +00:00
|
|
|
|
2015-02-11 17:33:55 +00:00
|
|
|
commitMsg :: Annex String
|
|
|
|
commitMsg = do
|
|
|
|
u <- getUUID
|
|
|
|
m <- uuidMap
|
|
|
|
return $ "git-annex in " ++ fromMaybe "unknown" (M.lookup u m)
|
|
|
|
|
2014-07-04 15:36:59 +00:00
|
|
|
commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool
|
2015-03-04 19:25:13 +00:00
|
|
|
commitStaged commitmode commitmessage = do
|
|
|
|
runAnnexHook preCommitAnnexHook
|
|
|
|
mb <- inRepo Git.Branch.currentUnsafe
|
|
|
|
let (getparent, branch) = case mb of
|
|
|
|
Just b -> (Git.Ref.sha b, b)
|
|
|
|
Nothing -> (Git.Ref.headSha, Git.Ref.headRef)
|
|
|
|
parents <- maybeToList <$> inRepo getparent
|
|
|
|
void $ inRepo $ Git.Branch.commit commitmode False commitmessage branch parents
|
|
|
|
return True
|
2011-12-10 16:21:22 +00:00
|
|
|
|
2013-11-02 19:29:38 +00:00
|
|
|
mergeLocal :: Maybe Git.Ref -> CommandStart
|
|
|
|
mergeLocal Nothing = stop
|
|
|
|
mergeLocal (Just branch) = go =<< needmerge
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
syncbranch = syncBranch branch
|
2013-08-17 19:29:44 +00:00
|
|
|
needmerge = ifM isBareRepo
|
|
|
|
( return False
|
2015-07-07 19:45:41 +00:00
|
|
|
, ifM (inRepo $ Git.Ref.exists syncbranch)
|
|
|
|
( inRepo $ Git.Branch.changed branch syncbranch
|
|
|
|
, return False
|
|
|
|
)
|
2013-08-17 19:29:44 +00:00
|
|
|
)
|
2012-11-12 05:05:04 +00:00
|
|
|
go False = stop
|
|
|
|
go True = do
|
|
|
|
showStart "merge" $ Git.Ref.describe syncbranch
|
2014-07-04 15:36:59 +00:00
|
|
|
next $ next $ autoMergeFrom syncbranch (Just branch) Git.Branch.ManualCommit
|
2011-12-29 17:37:30 +00:00
|
|
|
|
2013-11-02 19:29:38 +00:00
|
|
|
pushLocal :: Maybe Git.Ref -> CommandStart
|
2014-06-16 15:32:13 +00:00
|
|
|
pushLocal b = do
|
|
|
|
updateSyncBranch b
|
|
|
|
stop
|
|
|
|
|
|
|
|
updateSyncBranch :: Maybe Git.Ref -> Annex ()
|
|
|
|
updateSyncBranch Nothing = noop
|
|
|
|
updateSyncBranch (Just branch) = do
|
work around lack of receive.denyCurrentBranch in direct mode
Now that direct mode sets core.bare=true, git's normal prohibition about
pushing into the currently checked out branch doesn't work.
A simple fix for this would be an update hook which blocks the pushes..
but git hooks must be executable, and git-annex needs to be usable on eg,
FAT, which lacks x bits.
Instead, enabling direct mode switches the branch (eg master) to a special
purpose branch (eg annex/direct/master). This branch is not pushed when
syncing; instead any changes that git annex sync commits get written to
master, and it's pushed (along with synced/master) to the remote.
Note that initialization has been changed to always call setDirect,
even if it's just setDirect False for indirect mode. This is needed because
if the user has just cloned a direct mode repo, that nothing has synced
with before, it may have no master branch, and only a annex/direct/master.
Resulting in that branch being checked out locally too. Calling setDirect False
for indirect mode moves back out of this branch, to a new master branch,
and ensures that a manual "git push" doesn't push changes directly to
the annex/direct/master of the remote. (It's possible that the user
makes a commit w/o using git-annex and pushes it, but nothing I can do
about that really.)
This commit was sponsored by Jonathan Harrington.
2013-11-06 01:08:31 +00:00
|
|
|
-- Update the sync branch to match the new state of the branch
|
2012-06-22 19:46:21 +00:00
|
|
|
inRepo $ updateBranch $ syncBranch branch
|
work around lack of receive.denyCurrentBranch in direct mode
Now that direct mode sets core.bare=true, git's normal prohibition about
pushing into the currently checked out branch doesn't work.
A simple fix for this would be an update hook which blocks the pushes..
but git hooks must be executable, and git-annex needs to be usable on eg,
FAT, which lacks x bits.
Instead, enabling direct mode switches the branch (eg master) to a special
purpose branch (eg annex/direct/master). This branch is not pushed when
syncing; instead any changes that git annex sync commits get written to
master, and it's pushed (along with synced/master) to the remote.
Note that initialization has been changed to always call setDirect,
even if it's just setDirect False for indirect mode. This is needed because
if the user has just cloned a direct mode repo, that nothing has synced
with before, it may have no master branch, and only a annex/direct/master.
Resulting in that branch being checked out locally too. Calling setDirect False
for indirect mode moves back out of this branch, to a new master branch,
and ensures that a manual "git push" doesn't push changes directly to
the annex/direct/master of the remote. (It's possible that the user
makes a commit w/o using git-annex and pushes it, but nothing I can do
about that really.)
This commit was sponsored by Jonathan Harrington.
2013-11-06 01:08:31 +00:00
|
|
|
-- In direct mode, we're operating on some special direct mode
|
|
|
|
-- branch, rather than the intended branch, so update the indended
|
|
|
|
-- branch.
|
|
|
|
whenM isDirect $
|
|
|
|
inRepo $ updateBranch $ fromDirectBranch branch
|
2011-12-30 22:52:24 +00:00
|
|
|
|
2012-06-22 19:46:21 +00:00
|
|
|
updateBranch :: Git.Ref -> Git.Repo -> IO ()
|
|
|
|
updateBranch syncbranch g =
|
2014-02-19 05:09:17 +00:00
|
|
|
unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2013-03-03 17:39:07 +00:00
|
|
|
go = Git.Command.runBool
|
|
|
|
[ Param "branch"
|
|
|
|
, Param "-f"
|
2014-02-19 05:09:17 +00:00
|
|
|
, Param $ Git.fromRef $ Git.Ref.base syncbranch
|
2012-11-12 05:05:04 +00:00
|
|
|
] g
|
2011-12-30 21:38:38 +00:00
|
|
|
|
2015-09-13 17:15:35 +00:00
|
|
|
pullRemote :: SyncOptions -> Remote -> Maybe Git.Ref -> CommandStart
|
|
|
|
pullRemote o remote branch = stopUnless (pure $ pullOption o) $ do
|
2011-12-30 22:04:01 +00:00
|
|
|
showStart "pull" (Remote.name remote)
|
2011-12-30 21:38:38 +00:00
|
|
|
next $ do
|
|
|
|
showOutput
|
2012-03-14 21:43:34 +00:00
|
|
|
stopUnless fetch $
|
2013-11-02 19:29:38 +00:00
|
|
|
next $ mergeRemote remote branch
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2015-02-12 20:12:32 +00:00
|
|
|
fetch = inRepoWithSshOptionsTo (Remote.repo remote) (Remote.gitconfig remote) $
|
|
|
|
Git.Command.runBool
|
|
|
|
[Param "fetch", Param $ Remote.name remote]
|
2011-12-10 00:27:22 +00:00
|
|
|
|
2011-12-30 23:11:22 +00:00
|
|
|
{- The remote probably has both a master and a synced/master branch.
|
|
|
|
- Which to merge from? Well, the master has whatever latest changes
|
2013-06-12 18:54:23 +00:00
|
|
|
- were committed (or pushed changes, if this is a bare remote),
|
|
|
|
- while the synced/master may have changes that some
|
2012-12-12 17:06:03 +00:00
|
|
|
- other remote synced to this remote. So, merge them both. -}
|
2013-09-25 07:09:06 +00:00
|
|
|
mergeRemote :: Remote -> Maybe Git.Ref -> CommandCleanup
|
2015-01-05 17:40:49 +00:00
|
|
|
mergeRemote remote b = ifM isBareRepo
|
|
|
|
( return True
|
|
|
|
, case b of
|
|
|
|
Nothing -> do
|
|
|
|
branch <- inRepo Git.Branch.currentUnsafe
|
|
|
|
and <$> mapM (merge Nothing) (branchlist branch)
|
2015-07-07 19:45:41 +00:00
|
|
|
Just thisbranch -> do
|
|
|
|
inRepo $ updateBranch $ syncBranch thisbranch
|
2015-01-05 17:40:49 +00:00
|
|
|
and <$> (mapM (merge (Just thisbranch)) =<< tomerge (branchlist b))
|
|
|
|
)
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2014-07-04 15:36:59 +00:00
|
|
|
merge thisbranch br = autoMergeFrom (remoteBranch remote br) thisbranch Git.Branch.ManualCommit
|
2014-02-11 17:11:49 +00:00
|
|
|
tomerge = filterM (changed remote)
|
2012-11-12 05:05:04 +00:00
|
|
|
branchlist Nothing = []
|
|
|
|
branchlist (Just branch) = [branch, syncBranch branch]
|
2011-12-30 23:11:22 +00:00
|
|
|
|
2015-09-13 17:15:35 +00:00
|
|
|
pushRemote :: SyncOptions -> Remote -> Maybe Git.Ref -> CommandStart
|
|
|
|
pushRemote _o _remote Nothing = stop
|
|
|
|
pushRemote o remote (Just branch) = stopUnless (pure (pushOption o) <&&> needpush) $ do
|
|
|
|
showStart "push" (Remote.name remote)
|
|
|
|
next $ next $ do
|
|
|
|
showOutput
|
|
|
|
ok <- inRepoWithSshOptionsTo (Remote.repo remote) (Remote.gitconfig remote) $
|
|
|
|
pushBranch remote branch
|
|
|
|
unless ok $ do
|
|
|
|
warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
|
|
|
|
showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)"
|
|
|
|
return ok
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2014-01-02 17:12:32 +00:00
|
|
|
needpush
|
2014-04-12 19:59:34 +00:00
|
|
|
| remoteAnnexReadOnly (Remote.gitconfig remote) = return False
|
2014-01-02 17:12:32 +00:00
|
|
|
| otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
|
2012-06-22 19:46:21 +00:00
|
|
|
|
2013-08-29 18:15:32 +00:00
|
|
|
{- Pushes a regular branch like master to a remote. Also pushes the git-annex
|
|
|
|
- branch.
|
|
|
|
-
|
|
|
|
- If the remote is a bare git repository, it's best to push the regular
|
|
|
|
- branch directly to it, so that cloning/pulling will get it.
|
|
|
|
- On the other hand, if it's not bare, pushing to the checked out branch
|
|
|
|
- will fail, and this is why we push to its syncBranch.
|
2013-06-12 18:54:23 +00:00
|
|
|
-
|
|
|
|
- Git offers no way to tell if a remote is bare or not, so both methods
|
|
|
|
- are tried.
|
|
|
|
-
|
|
|
|
- The direct push is likely to spew an ugly error message, so stderr is
|
2013-08-29 18:15:32 +00:00
|
|
|
- elided. Since git progress display goes to stderr too, the sync push
|
|
|
|
- is done first, and actually sends the data. Then the direct push is
|
|
|
|
- tried, with stderr discarded, to update the branch ref on the remote.
|
|
|
|
-
|
|
|
|
- The sync push forces the update of the remote synced/git-annex branch.
|
|
|
|
- This is necessary if a transition has rewritten the git-annex branch.
|
|
|
|
- Normally any changes to the git-annex branch get pulled and merged before
|
|
|
|
- this push, so this forcing is unlikely to overwrite new data pushed
|
|
|
|
- in from another repository that is also syncing.
|
|
|
|
-
|
|
|
|
- But overwriting of data on synced/git-annex can happen, in a race.
|
|
|
|
- The only difference caused by using a forced push in that case is that
|
|
|
|
- the last repository to push wins the race, rather than the first to push.
|
2013-10-26 19:53:05 +00:00
|
|
|
-
|
|
|
|
- The sync push will fail to overwrite if receive.denyNonFastforwards is
|
|
|
|
- set on the remote.
|
2013-06-12 18:54:23 +00:00
|
|
|
-}
|
2012-06-22 19:46:21 +00:00
|
|
|
pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool
|
2013-08-29 18:15:32 +00:00
|
|
|
pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
|
2013-06-12 18:54:23 +00:00
|
|
|
where
|
2013-08-29 18:15:32 +00:00
|
|
|
syncpush = Git.Command.runBool $ pushparams
|
|
|
|
[ Git.Branch.forcePush $ refspec Annex.Branch.name
|
|
|
|
, refspec branch
|
|
|
|
]
|
|
|
|
directpush = Git.Command.runQuiet $ pushparams
|
2015-02-27 18:49:56 +00:00
|
|
|
[ Git.fromRef $ Git.Ref.base $ Annex.Branch.name
|
|
|
|
, Git.fromRef $ Git.Ref.base $ fromDirectBranch branch
|
|
|
|
]
|
2013-08-29 18:15:32 +00:00
|
|
|
pushparams branches =
|
2013-03-03 17:39:07 +00:00
|
|
|
[ Param "push"
|
|
|
|
, Param $ Remote.name remote
|
2013-08-29 18:15:32 +00:00
|
|
|
] ++ map Param branches
|
2012-11-12 05:05:04 +00:00
|
|
|
refspec b = concat
|
2014-02-19 05:09:17 +00:00
|
|
|
[ Git.fromRef $ Git.Ref.base b
|
2012-11-12 05:05:04 +00:00
|
|
|
, ":"
|
2014-02-19 05:09:17 +00:00
|
|
|
, Git.fromRef $ Git.Ref.base $ syncBranch b
|
2012-11-12 05:05:04 +00:00
|
|
|
]
|
2011-12-29 17:37:30 +00:00
|
|
|
|
2014-02-01 14:49:50 +00:00
|
|
|
commitAnnex :: CommandStart
|
|
|
|
commitAnnex = do
|
|
|
|
Annex.Branch.commit "update"
|
|
|
|
stop
|
|
|
|
|
2011-12-30 20:03:41 +00:00
|
|
|
mergeAnnex :: CommandStart
|
2011-12-30 21:38:38 +00:00
|
|
|
mergeAnnex = do
|
2013-09-25 07:09:06 +00:00
|
|
|
void Annex.Branch.forceUpdate
|
2011-12-30 21:38:38 +00:00
|
|
|
stop
|
2011-12-31 06:18:16 +00:00
|
|
|
|
2011-12-31 08:11:39 +00:00
|
|
|
changed :: Remote -> Git.Ref -> Annex Bool
|
2011-12-31 07:01:18 +00:00
|
|
|
changed remote b = do
|
|
|
|
let r = remoteBranch remote b
|
2012-03-14 21:43:34 +00:00
|
|
|
ifM (inRepo $ Git.Ref.exists r)
|
|
|
|
( inRepo $ Git.Branch.changed b r
|
|
|
|
, return False
|
|
|
|
)
|
2011-12-31 07:01:18 +00:00
|
|
|
|
2011-12-31 08:11:39 +00:00
|
|
|
newer :: Remote -> Git.Ref -> Annex Bool
|
2011-12-31 07:01:18 +00:00
|
|
|
newer remote b = do
|
|
|
|
let r = remoteBranch remote b
|
2012-03-14 21:43:34 +00:00
|
|
|
ifM (inRepo $ Git.Ref.exists r)
|
|
|
|
( inRepo $ Git.Branch.changed r b
|
|
|
|
, return True
|
|
|
|
)
|
2014-01-19 21:35:36 +00:00
|
|
|
|
2015-06-16 22:38:12 +00:00
|
|
|
{- Without --all, only looks at files in the work tree. With --all,
|
|
|
|
- makes 2 passes, first looking at the work tree and then all keys.
|
|
|
|
- This ensures that preferred content expressions that match on
|
|
|
|
- filenames work, even when in --all mode.
|
|
|
|
-
|
2015-08-14 17:49:55 +00:00
|
|
|
- Returns true if any file transfers were made.
|
|
|
|
-
|
|
|
|
- When concurrency is enabled, files are processed concurrently.
|
2014-01-19 21:35:36 +00:00
|
|
|
-}
|
2015-07-09 23:03:21 +00:00
|
|
|
seekSyncContent :: SyncOptions -> [Remote] -> Annex Bool
|
|
|
|
seekSyncContent o rs = do
|
2014-02-11 17:11:49 +00:00
|
|
|
mvar <- liftIO newEmptyMVar
|
2015-07-09 23:03:21 +00:00
|
|
|
bloom <- case keyOptions o of
|
|
|
|
Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar [])
|
|
|
|
_ -> seekworktree mvar [] (const noop) >> pure Nothing
|
|
|
|
withKeyOptions' (keyOptions o) False
|
|
|
|
(seekkeys mvar bloom)
|
|
|
|
(const noop)
|
|
|
|
[]
|
2015-08-14 17:49:55 +00:00
|
|
|
finishCommandActions
|
2014-02-01 14:49:50 +00:00
|
|
|
liftIO $ not <$> isEmptyMVar mvar
|
2014-01-20 17:31:03 +00:00
|
|
|
where
|
2015-06-16 22:38:12 +00:00
|
|
|
seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>=
|
|
|
|
mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (Just f)) noop)
|
|
|
|
seekkeys mvar bloom getkeys =
|
|
|
|
mapM_ (go (Left bloom) mvar Nothing) =<< getkeys
|
2015-08-14 17:49:55 +00:00
|
|
|
go ebloom mvar af k = commandAction $ do
|
|
|
|
whenM (syncFile ebloom rs af k) $
|
|
|
|
void $ liftIO $ tryPutMVar mvar ()
|
|
|
|
return Nothing
|
2014-01-20 17:31:03 +00:00
|
|
|
|
2015-06-16 23:07:14 +00:00
|
|
|
{- If it's preferred content, and we don't have it, get it from one of the
|
|
|
|
- listed remotes (preferring the cheaper earlier ones).
|
|
|
|
-
|
|
|
|
- Send it to each remote that doesn't have it, and for which it's
|
|
|
|
- preferred content.
|
|
|
|
-
|
|
|
|
- Drop it locally if it's not preferred content (honoring numcopies).
|
|
|
|
-
|
|
|
|
- Drop it from each remote that has it, where it's not preferred content
|
|
|
|
- (honoring numcopies).
|
2015-08-14 17:49:55 +00:00
|
|
|
-
|
|
|
|
- Returns True if any file transfers were made.
|
2015-06-16 23:07:14 +00:00
|
|
|
-}
|
2015-08-14 17:49:55 +00:00
|
|
|
syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool
|
2015-06-16 22:38:12 +00:00
|
|
|
syncFile ebloom rs af k = do
|
2014-01-19 21:35:36 +00:00
|
|
|
locs <- loggedLocations k
|
|
|
|
let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs
|
|
|
|
|
2014-02-03 02:46:55 +00:00
|
|
|
got <- anyM id =<< handleget have
|
2015-07-20 18:24:13 +00:00
|
|
|
putrs <- handleput lack
|
2014-01-20 17:31:03 +00:00
|
|
|
|
2014-02-03 02:46:55 +00:00
|
|
|
u <- getUUID
|
2014-02-11 17:11:49 +00:00
|
|
|
let locs' = concat [[u | got], putrs, locs]
|
2014-02-03 02:46:55 +00:00
|
|
|
|
2015-06-16 22:38:12 +00:00
|
|
|
-- A bloom filter is populated with all the keys in the first pass.
|
|
|
|
-- On the second pass, avoid dropping keys that were seen in the
|
|
|
|
-- first pass, which would happen otherwise when preferred content
|
|
|
|
-- matches on the filename, which is not available in the second
|
|
|
|
-- pass.
|
|
|
|
--
|
|
|
|
-- When there's a false positive in the bloom filter, the result
|
|
|
|
-- is keeping a key that preferred content doesn't really want.
|
|
|
|
seenbloom <- case ebloom of
|
2015-06-16 23:04:20 +00:00
|
|
|
Left Nothing -> pure False
|
|
|
|
Left (Just bloom) -> pure (elemB k bloom)
|
2015-06-16 22:38:12 +00:00
|
|
|
Right bloomfeeder -> bloomfeeder k >> return False
|
|
|
|
unless seenbloom $
|
|
|
|
-- Using callCommandAction rather than
|
|
|
|
-- includeCommandAction for drops,
|
|
|
|
-- because a failure to drop does not mean
|
|
|
|
-- the sync failed.
|
|
|
|
handleDropsFrom locs' rs "unwanted" True k af
|
|
|
|
Nothing callCommandAction
|
2015-08-14 17:49:55 +00:00
|
|
|
|
|
|
|
return (got || not (null putrs))
|
2014-01-20 17:31:03 +00:00
|
|
|
where
|
2014-10-09 18:53:13 +00:00
|
|
|
wantget have = allM id
|
2014-01-19 21:35:36 +00:00
|
|
|
[ pure (not $ null have)
|
|
|
|
, not <$> inAnnex k
|
2015-06-16 19:07:03 +00:00
|
|
|
, wantGet True (Just k) af
|
2014-01-19 21:35:36 +00:00
|
|
|
]
|
|
|
|
handleget have = ifM (wantget have)
|
|
|
|
( return [ get have ]
|
|
|
|
, return []
|
|
|
|
)
|
2015-04-10 21:08:07 +00:00
|
|
|
get have = includeCommandAction $ do
|
2015-06-16 19:07:03 +00:00
|
|
|
showStart' "get" k af
|
|
|
|
next $ next $ getViaTmp k $ \dest -> getKeyFile' k af dest have
|
2014-01-19 21:35:36 +00:00
|
|
|
|
|
|
|
wantput r
|
2014-04-12 19:59:34 +00:00
|
|
|
| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False
|
2015-06-16 19:07:03 +00:00
|
|
|
| otherwise = wantSend True (Just k) af (Remote.uuid r)
|
2015-07-20 18:24:13 +00:00
|
|
|
handleput lack = catMaybes <$> ifM (inAnnex k)
|
|
|
|
( forM lack $ \r ->
|
|
|
|
ifM (wantput r <&&> put r)
|
|
|
|
( return (Just (Remote.uuid r))
|
|
|
|
, return Nothing
|
|
|
|
)
|
2014-01-19 21:35:36 +00:00
|
|
|
, return []
|
|
|
|
)
|
2015-07-20 18:24:13 +00:00
|
|
|
put dest = includeCommandAction $ do
|
|
|
|
showStart' "copy" k af
|
|
|
|
Command.Move.toStart' dest False af k
|