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.

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 ->
-		sendNetMessage $ Pushing (getXMPPClientID r) (CanPush u)
+	unless (null xmppremotes) $ do
+		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) =
-		gitAnnexTag canPushAttr $ T.pack $ fromUUID u
+	encode (CanPush u shas) =
+		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)) =
-	unlessM (null <$> xmppRemotes cid theiruuid) $ do
+handlePushNotice (Pushing cid (CanPush theiruuid shas)) =
+	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 ()