XMPP: Avoid redundant and unncessary pushes. Note that this breaks compatibility with previous versions of git-annex, which will refuse to accept any XMPP pushes from this version.

Annex/Branch.hs

@@ -65,7 +65,7 @@ hasSibling = not . null <$> siblingBranches
 {- List of git-annex (refs, branches), including the main one and any
  - from remotes. Duplicate refs are filtered out. -}
 siblingBranches :: Annex [(Git.Ref, Git.Branch)]
-siblingBranches = inRepo $ Git.Ref.matchingUniq name
+siblingBranches = inRepo $ Git.Ref.matchingUniq [name]
 
 {- Creates the branch, if it does not already exist. -}
 create :: Annex ()

Assistant/Sync.hs

@@ -20,6 +20,7 @@ import Utility.Parallel
 import qualified Git
 import qualified Git.Branch
 import qualified Git.Command
+import qualified Git.Ref
 import qualified Remote
 import qualified Types.Remote as Remote
 import qualified Annex.Branch
@@ -112,8 +113,11 @@ pushToRemotes' now notifypushes remotes = do
 			<*> getUUID
 	let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
 	ret <- go True branch g u normalremotes
-	forM_ xmppremotes $ \r ->
+	unless (null xmppremotes) $ do
-		sendNetMessage $ Pushing (getXMPPClientID r) (CanPush u)
+		shas <- liftAnnex $ map fst <$>
+			inRepo (Git.Ref.matching [Annex.Branch.fullname, Git.Ref.headRef])
+		forM_ xmppremotes $ \r -> sendNetMessage $
+			Pushing (getXMPPClientID r) (CanPush u shas)
 	return ret
   where
 	go _ Nothing _ _ _ = return [] -- no branch, so nothing to do

Assistant/Types/NetMessager.hs

@@ -9,6 +9,7 @@ module Assistant.Types.NetMessager where
 
 import Common.Annex
 import Assistant.Pairing
+import Git.Types
 
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
@@ -38,7 +39,7 @@ type ClientID = Text
 
 data PushStage
 	-- indicates that we have data to push over the out of band network
-	= CanPush UUID
+	= CanPush UUID [Sha]
 	-- request that a git push be sent over the out of band network
 	| PushRequest UUID
 	-- indicates that a push is starting
@@ -59,7 +60,7 @@ type SequenceNum = Int
 {- NetMessages that are important (and small), and should be stored to be
  - resent when new clients are seen. -}
 isImportantNetMessage :: NetMessage -> Maybe ClientID
-isImportantNetMessage (Pushing c (CanPush _)) = Just c
+isImportantNetMessage (Pushing c (CanPush _ _)) = Just c
 isImportantNetMessage (Pushing c (PushRequest _)) = Just c
 isImportantNetMessage _ = Nothing
 
@@ -91,14 +92,14 @@ isPushInitiation (StartingPush _) = True
 isPushInitiation _ = False
 
 isPushNotice :: PushStage -> Bool
-isPushNotice (CanPush _) = True
+isPushNotice (CanPush _ _) = True
 isPushNotice _ = False
 
 data PushSide = SendPack | ReceivePack
 	deriving (Eq, Ord, Show)
 
 pushDestinationSide :: PushStage -> PushSide
-pushDestinationSide (CanPush _) = ReceivePack
+pushDestinationSide (CanPush _ _) = ReceivePack
 pushDestinationSide (PushRequest _) = SendPack
 pushDestinationSide (StartingPush _) = ReceivePack
 pushDestinationSide (ReceivePackOutput _ _) = SendPack

Assistant/XMPP.hs

@@ -1,6 +1,6 @@
 {- core xmpp support
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -12,6 +12,7 @@ module Assistant.XMPP where
 import Assistant.Common
 import Assistant.Types.NetMessager
 import Assistant.Pairing
+import Git.Sha (extractSha)
 
 import Network.Protocol.XMPP hiding (Node)
 import Data.Text (Text)
@@ -131,8 +132,9 @@ decodePairingNotification m = parse . words . T.unpack . tagValue
 pushMessage :: PushStage -> JID -> JID -> Message
 pushMessage = gitAnnexMessage . encode
   where
-	encode (CanPush u) =
+	encode (CanPush u shas) =
-		gitAnnexTag canPushAttr $ T.pack $ fromUUID u
+		gitAnnexTag canPushAttr $ T.pack $ unwords $
+			fromUUID u : map show shas
 	encode (PushRequest u) =
 		gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
 	encode (StartingPush u) =
@@ -160,7 +162,7 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
 		, receivePackDoneAttr
 		]
 		[ decodePairingNotification
-		, pushdecoder $ gen CanPush
+		, pushdecoder $ shasgen CanPush
 		, pushdecoder $ gen PushRequest
 		, pushdecoder $ gen StartingPush
 		, pushdecoder $ seqgen ReceivePackOutput
@@ -172,11 +174,14 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
 	pushdecoder a m' i = Pushing
 		<$> (formatJID <$> messageFrom m')
 		<*> a i
-	gen c = Just . c . toUUID . T.unpack . tagValue
+	gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i)))
 	seqgen c i = do
 	  	packet <- decodeTagContent $ tagElement i
 		let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i
 		return $ c seqnum packet
+	shasgen c i = do
+		let (u:shas) = words $ T.unpack $ tagValue i
+		return $ c (toUUID u) (mapMaybe extractSha shas)
 
 decodeExitCode :: Int -> ExitCode
 decodeExitCode 0 = ExitSuccess
@@ -245,3 +250,6 @@ sendPackAttr = "sp"
 
 receivePackDoneAttr :: Name
 receivePackDoneAttr = "rpdone"
+
+shasAttr :: Name
+shasAttr = "shas"

Assistant/XMPP/Git.hs

@@ -23,6 +23,7 @@ import qualified Annex.Branch
 import Annex.UUID
 import Logs.UUID
 import Annex.TaggedPush
+import Annex.CatFile
 import Config
 import Git
 import qualified Git.Branch
@@ -311,11 +312,27 @@ handlePushInitiation checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
 		mapM_ checkcloudrepos rs
 handlePushInitiation _ _ = noop
 
+{- Check if any of the shas that can be pushed are ones we do not
+ - have.
+ -
+ - (Older clients send no shas, so when there are none, always
+ - request a push.)
+ -}
 handlePushNotice :: NetMessage -> Assistant ()
-handlePushNotice (Pushing cid (CanPush theiruuid)) =
+handlePushNotice (Pushing cid (CanPush theiruuid shas)) =
-	unlessM (null <$> xmppRemotes cid theiruuid) $ do
+	unlessM (null <$> xmppRemotes cid theiruuid) $
+		if null shas
+			then go
+			else ifM (haveall shas)
+				( debug ["ignoring CanPush with known shas"]
+				, go
+				)
+  where
+  	go = do
 		u <- liftAnnex getUUID
 		sendNetMessage $ Pushing cid (PushRequest u)
+	haveall l = liftAnnex $ not <$> anyM donthave l
+	donthave sha = isNothing <$> catObjectDetails sha
 handlePushNotice _ = noop
 
 writeChunk :: Handle -> B.ByteString -> IO ()

Git/Branch.hs

@@ -13,6 +13,7 @@ import Common
 import Git
 import Git.Sha
 import Git.Command
+import Git.Ref (headRef)
 
 {- The currently checked out branch.
  -
@@ -35,7 +36,7 @@ current r = do
 {- The current branch, which may not really exist yet. -}
 currentUnsafe :: Repo -> IO (Maybe Git.Ref)
 currentUnsafe r = parse . firstLine
-	<$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r
+	<$> pipeReadStrict [Param "symbolic-ref", Param $ show headRef] r
   where
 	parse l
 		| null l = Nothing

Git/DiffTree.hs

@@ -46,7 +46,10 @@ diffTreeRecursive src dst = getdiff (Param "diff-tree")
 diffIndex :: Repo -> IO ([DiffTreeItem], IO Bool)
 diffIndex repo = do
 	ifM (Git.Ref.headExists repo)
-		( getdiff (Param "diff-index") [Param "--cached", Param "HEAD"] repo
+		( getdiff (Param "diff-index")
+			[ Param "--cached"
+			, Param $ show Git.Ref.headRef
+			] repo
 		, return ([], return True)
 		)
 

Git/Ref.hs

@@ -1,6 +1,6 @@
 {- git ref stuff
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -13,6 +13,9 @@ import Git.Command
 
 import Data.Char (chr)
 
+headRef :: Ref
+headRef = Ref "HEAD"
+
 {- Converts a fully qualified git ref into a user-visible string. -}
 describe :: Ref -> String
 describe = show . base
@@ -54,18 +57,18 @@ sha branch repo = process <$> showref repo
 	process [] = Nothing
 	process s = Just $ Ref $ firstLine s
 
-{- List of (refs, branches) matching a given ref spec. -}
+{- List of (shas, branches) matching a given ref or refs. -}
-matching :: Ref -> Repo -> IO [(Ref, Branch)]
+matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
-matching ref repo = map gen . lines <$> 
+matching refs repo = map gen . lines <$> 
-	pipeReadStrict [Param "show-ref", Param $ show ref] repo
+	pipeReadStrict (Param "show-ref" : map (Param . show) refs) repo
   where
 	gen l = let (r, b) = separate (== ' ') l
 		in (Ref r, Ref b)
 
-{- List of (refs, branches) matching a given ref spec.
+{- List of (shas, branches) matching a given ref spec.
- - Duplicate refs are filtered out. -}
+ - Duplicate shas are filtered out. -}
-matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)]
+matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)]
-matchingUniq ref repo = nubBy uniqref <$> matching ref repo
+matchingUniq refs repo = nubBy uniqref <$> matching refs repo
   where
 	uniqref (a, _) (b, _) = a == b
 

Git/Types.hs

@@ -41,7 +41,7 @@ data Repo = Repo
 
 {- A git ref. Can be a sha1, or a branch or tag name. -}
 newtype Ref = Ref String
-	deriving (Eq)
+	deriving (Eq, Ord)
 
 instance Show Ref where
 	show (Ref v) = v

debian/changelog

@@ -1,3 +1,12 @@
+git-annex (4.20130522) UNRELEASED; urgency=low
+
+  * XMPP: Made much more robust.
+  * XMPP: Avoid redundant and unncessary pushes. Note that this breaks
+    compatibility with previous versions of git-annex, which will refuse
+    to accept any XMPP pushes from this version.
+
+ -- Joey Hess <joeyh@debian.org>  Tue, 21 May 2013 18:22:46 -0400
+
 git-annex (4.20130521) unstable; urgency=low
 
   * Sanitize debian changelog version before putting it into cabal file.

doc/design/assistant/xmpp.mdwn

@@ -66,7 +66,11 @@ containing:
 To indicate that we could push over XMPP, a chat message is sent,
 to each known client of each XMPP remote.
 
-	<git-annex xmlns='git-annex' canpush="myuuid" />
+	<git-annex xmlns='git-annex' canpush="myuuid" shas="sha1 sha1" />
+
+The shas are omitted by old clients. If present, they are the git shas of
+the head and git-annex branches that are available to be pushed. This lets
+the receiver check if it's already got them.
 
 To request that a remote push to us, a chat message can be sent.