git-annex/Command/Sync.hs

{- git-annex command
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE BangPatterns #-}

module Command.Sync where

import Common.Annex
import Command
import qualified Remote
import qualified Annex.Branch
import qualified Git.Command
import qualified Git.Config
import qualified Git.Ref
import qualified Git

import qualified Data.ByteString.Lazy.Char8 as L

def :: [Command]
def = [command "sync" (paramOptional (paramRepeating paramRemote))
	[seek] "synchronize local repository with remote repositories"]

-- syncing involves several operations, any of which can independantly fail
seek :: CommandSeek
seek args = do
	!branch <- currentBranch
	let syncbranch = Git.Ref.under "refs/heads/synced/" branch
	remotes <- syncRemotes syncbranch args
	return $ concat $
		[ [ commit ]
		, [ mergeLocal branch ]
		, [ update remote branch | remote <- remotes ]
		, [ mergeAnnex ]
		, [ pushLocal syncbranch ]
		, [ pushRemote remote branch syncbranch | remote <- remotes ]
		]

syncRemotes :: Git.Ref -> [String] -> Annex [Remote.Remote Annex]
syncRemotes branch [] = defaultSyncRemotes branch
syncRemotes _ rs = mapM Remote.byName rs

defaultSyncRemotes :: Git.Ref -> Annex [Remote.Remote Annex]
defaultSyncRemotes syncbranch = mapM Remote.byName
		=<< process . L.unpack <$> inRepo showref
	where
		showref = Git.Command.pipeRead
			[ Param "show-ref"
			, Param $ show $ Git.Ref.base syncbranch
			]
		process = map getRemoteName . filter isRemote .
			map getBranchName . lines
	        isRemote r = "refs/remotes/" `isPrefixOf` r
		getBranchName = snd . separate (== ' ')
		getRemoteName = fst . separate (== '/') . snd . separate (== '/') . snd . separate (== '/')

commit :: CommandStart
commit = do
	showStart "commit" ""
	next $ next $ do
		showOutput
		-- Commit will fail when the tree is clean, so ignore failure.
		_ <- inRepo $ Git.Command.runBool "commit"
			[Param "-a", Param "-m", Param "git-annex automatic sync"]
		return True

mergeLocal :: Git.Ref -> CommandStart
mergeLocal branch = do
	let mergebranch = Git.Ref.under "refs/heads/synced" branch
	showStart "merge" $ Git.Ref.describe mergebranch
	next $ next $ mergeFromIfExists mergebranch

pushLocal :: Git.Ref -> CommandStart
pushLocal syncbranch = go =<< inRepo (Git.Ref.exists syncbranch)
	where
		go False = stop
		go True = do
			unlessM (updatebranch) $
				error $ "failed to update " ++ show syncbranch
			stop
		updatebranch = inRepo $ Git.Command.runBool "branch"
			[ Param "-f"
			, Param $ show $ Git.Ref.base syncbranch
			]

mergeFromIfExists :: Git.Ref -> CommandCleanup
mergeFromIfExists branch = go =<< inRepo (Git.Ref.exists branch)
	where
		go True = do
			showOutput
			inRepo $ Git.Command.runBool "merge"
				[Param (show branch)]
		go False = do
			showNote $ Git.Ref.describe branch ++
				" does not exist, not merging"
			return False

update :: Remote.Remote Annex -> Git.Ref -> CommandStart
update remote branch = do
	showStart "update" (Remote.name remote)
	next $ do
		checkRemote remote
		showOutput
		fetched <- inRepo $ Git.Command.runBool "fetch" [Param (Remote.name remote)]
		if fetched
			then next $ mergeRemote remote branch
			else stop

mergeRemote :: Remote.Remote Annex -> Git.Ref -> CommandCleanup
mergeRemote remote = mergeFromIfExists .
	Git.Ref.under ("refs/remotes/" ++ Remote.name remote ++ "/synced")

pushRemote :: Remote.Remote Annex -> Git.Ref -> Git.Ref -> CommandStart
pushRemote remote branch syncbranch = do
	showStart "push" (Remote.name remote)
	let syncbranchRemote = Git.Ref.under
		("refs/remotes/" ++ Remote.name remote) syncbranch
	let refspec = show (Git.Ref.base branch) ++ ":" ++ show (Git.Ref.base syncbranch)
	ex <- inRepo $ Git.Ref.exists syncbranchRemote
	next $ next $ do
		showOutput
		inRepo $ Git.Command.runBool "push" $
			[ Param (Remote.name remote)
			, Param (show $ Annex.Branch.name) ] ++ 
			[ Param refspec | ex ]

currentBranch :: Annex Git.Ref
currentBranch = Git.Ref . firstLine . L.unpack <$>
	inRepo (Git.Command.pipeRead [Param "symbolic-ref", Param "HEAD"])

checkRemote :: Remote.Remote Annex -> Annex ()
checkRemote remote = do
	remoteurl <- fromRepo $
		Git.Config.get ("remote." ++ Remote.name remote ++ ".url") ""
	when (null remoteurl) $
		error $ "No url is configured for the remote: " ++ Remote.name remote

mergeAnnex :: CommandStart
mergeAnnex = do
	Annex.Branch.forceUpdate
	stop