add uuid to all xmpp messages

(Except for the actual streaming of receive-pack through XMPP, which
can only run once we've gotten an appropriate uuid in a push initiation
message.)

Pushes are now only initiated when the initiation message comes from a
known uuid. This allows multiple distinct repositories to use the same xmpp
address.

Note: This probably breaks initial push after xmpp pairing, because at that
point we may not know about the paired uuid, and so reject the push from
it. It won't break in simple cases, because the annex-uuid of the remote
is checked. However, when there are multiple clients behind a single xmpp
address, only uuid of the first is recorded in annex-uuid, and so any
pushes from the others will be rejected (unless the first remote pushes their
uuids to us beforehand.

4 files changed, 43 insertions, 33 deletions

diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 727749c4f..1b9de1656 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -113,7 +113,7 @@ pushToRemotes' now notifypushes remotes = do
 	let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
 	ret <- go True branch g u normalremotes
 	forM_ xmppremotes $ \r ->
-		sendNetMessage $ Pushing (getXMPPClientID r) CanPush
+		sendNetMessage $ Pushing (getXMPPClientID r) (CanPush u)
 	return ret
   where
 	go _ Nothing _ _ _ = return [] -- no branch, so nothing to do
@@ -202,8 +202,9 @@ manualPull currentbranch remotes = do
 	haddiverged <- liftAnnex Annex.Branch.forceUpdate
 	forM_ normalremotes $ \r ->
 		liftAnnex $ Command.Sync.mergeRemote r currentbranch
+	u <- liftAnnex getUUID
 	forM_ xmppremotes $ \r ->
-		sendNetMessage $ Pushing (getXMPPClientID r) PushRequest
+		sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u)
 	return (catMaybes failed, haddiverged)
 
 {- Start syncing a remote, using a background thread. -}
diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
index e0dcbbb56..09a558033 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/Assistant/Types/NetMessager.hs
@@ -37,11 +37,11 @@ type ClientID = Text
 
 data PushStage
 	-- indicates that we have data to push over the out of band network
-	= CanPush
+	= CanPush UUID
 	-- request that a git push be sent over the out of band network
-	| PushRequest
+	| PushRequest UUID
 	-- indicates that a push is starting
-	| StartingPush
+	| StartingPush UUID
 	-- a chunk of output of git receive-pack
 	| ReceivePackOutput SequenceNum ByteString
 	-- a chuck of output of git send-pack
@@ -58,8 +58,8 @@ 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 PushRequest) = Just c
+isImportantNetMessage (Pushing c (CanPush _)) = Just c
+isImportantNetMessage (Pushing c (PushRequest _)) = Just c
 isImportantNetMessage _ = Nothing
 
 readdressNetMessage :: NetMessage -> ClientID -> NetMessage
@@ -85,18 +85,18 @@ logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c]
 
 {- Things that initiate either side of a push, but do not actually send data. -}
 isPushInitiation :: PushStage -> Bool
-isPushInitiation CanPush = True
-isPushInitiation PushRequest = True
-isPushInitiation StartingPush = True
+isPushInitiation (CanPush _) = True
+isPushInitiation (PushRequest _) = True
+isPushInitiation (StartingPush _) = True
 isPushInitiation _ = False
 
 data PushSide = SendPack | ReceivePack
 	deriving (Eq, Ord)
 
 pushDestinationSide :: PushStage -> PushSide
-pushDestinationSide CanPush = ReceivePack
-pushDestinationSide PushRequest = SendPack
-pushDestinationSide StartingPush = ReceivePack
+pushDestinationSide (CanPush _) = ReceivePack
+pushDestinationSide (PushRequest _) = SendPack
+pushDestinationSide (StartingPush _) = ReceivePack
 pushDestinationSide (ReceivePackOutput _ _) = SendPack
 pushDestinationSide (SendPackOutput _ _) = ReceivePack
 pushDestinationSide (ReceivePackDone _) = SendPack
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 9654fdb4b..fbc351931 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -131,9 +131,12 @@ decodePairingNotification m = parse . words . T.unpack . tagValue
 pushMessage :: PushStage -> JID -> JID -> Message
 pushMessage = gitAnnexMessage . encode
   where
-	encode CanPush = gitAnnexTag canPushAttr T.empty
-	encode PushRequest = gitAnnexTag pushRequestAttr T.empty
-	encode StartingPush = gitAnnexTag startingPushAttr T.empty
+	encode (CanPush u) =
+		gitAnnexTag canPushAttr $ T.pack $ fromUUID u
+	encode (PushRequest u) =
+		gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
+	encode (StartingPush u) =
+		gitAnnexTag startingPushAttr $ T.pack $ fromUUID u
 	encode (ReceivePackOutput n b) = 
 		gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b
 	encode (SendPackOutput n b) =
@@ -157,11 +160,11 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
 		, receivePackDoneAttr
 		]
 		[ decodePairingNotification
-		, pushdecoder $ const $ Just CanPush
-		, pushdecoder $ const $ Just PushRequest
-		, pushdecoder $ const $ Just StartingPush
-		, pushdecoder $ gen ReceivePackOutput
-		, pushdecoder $ gen SendPackOutput
+		, pushdecoder $ gen CanPush
+		, pushdecoder $ gen PushRequest
+		, pushdecoder $ gen StartingPush
+		, pushdecoder $ seqgen ReceivePackOutput
+		, pushdecoder $ seqgen SendPackOutput
 		, pushdecoder $
 			fmap (ReceivePackDone . decodeExitCode) . readish .
 				T.unpack . tagValue
@@ -169,7 +172,8 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
 	pushdecoder a m' i = Pushing
 		<$> (formatJID <$> messageFrom m')
 		<*> a i
-	gen c i = do
+	gen c = Just . c . toUUID . T.unpack . tagValue
+	seqgen c i = do
 	  	packet <- decodeTagContent $ tagElement i
 		let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i
 		return $ c seqnum packet
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index 46c8cb173..c1605bee2 100644
--- a/Assistant/XMPP/Git.hs
+++ b/Assistant/XMPP/Git.hs
@@ -21,6 +21,7 @@ import Assistant.Sync
 import qualified Command.Sync
 import qualified Annex.Branch
 import Annex.UUID
+import Logs.UUID
 import Annex.TaggedPush
 import Config
 import Git
@@ -84,7 +85,8 @@ makeXMPPGitRemote buddyname jid u = do
  -}
 xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> (NetMessage -> Assistant ()) -> Assistant Bool
 xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
-	sendNetMessage $ Pushing cid StartingPush
+	u <- liftAnnex getUUID
+	sendNetMessage $ Pushing cid (StartingPush u)
 
 	(Fd inf, writepush) <- liftIO createPipe
 	(readpush, Fd outf) <- liftIO createPipe
@@ -247,26 +249,29 @@ xmppReceivePack cid handledeferred = runPush ReceivePack cid handledeferred $ do
 					hClose inh
 					killThread =<< myThreadId
 
-xmppRemotes :: ClientID -> Assistant [Remote]
-xmppRemotes cid = case baseJID <$> parseJID cid of
+xmppRemotes :: ClientID -> UUID -> Assistant [Remote]
+xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of
 	Nothing -> return []
 	Just jid -> do
 		let loc = gitXMPPLocation jid
-		filter (matching loc . Remote.repo) . syncGitRemotes 
+		um <- liftAnnex uuidMap
+		filter (matching loc . Remote.repo) . filter (knownuuid um) . syncGitRemotes 
 			<$> getDaemonStatus
   where
 	matching loc r = repoIsUrl r && repoLocation r == loc
+	knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um
 
 handlePushInitiation :: (Remote -> Assistant ()) -> NetMessage -> Assistant ()
-handlePushInitiation _ (Pushing cid CanPush) =
-	unlessM (null <$> xmppRemotes cid) $ 
-		sendNetMessage $ Pushing cid PushRequest
-handlePushInitiation checkcloudrepos (Pushing cid PushRequest) =
+handlePushInitiation _ (Pushing cid (CanPush theiruuid)) =
+	unlessM (null <$> xmppRemotes cid theiruuid) $ do
+		u <- liftAnnex getUUID
+		sendNetMessage $ Pushing cid (PushRequest u)
+handlePushInitiation checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
 	go =<< liftAnnex (inRepo Git.Branch.current)
   where
 	go Nothing = noop
 	go (Just branch) = do
-		rs <- xmppRemotes cid
+		rs <- xmppRemotes cid theiruuid
 		liftAnnex $ Annex.Branch.commit "update"
 		(g, u) <- liftAnnex $ (,)
 			<$> gitRepo
@@ -279,8 +284,8 @@ handlePushInitiation checkcloudrepos (Pushing cid PushRequest) =
 					(taggedPush u selfjid branch r)
 					(handleDeferred checkcloudrepos)
 			checkcloudrepos r
-handlePushInitiation checkcloudrepos (Pushing cid StartingPush) = do
-	rs <- xmppRemotes cid
+handlePushInitiation checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
+	rs <- xmppRemotes cid theiruuid
 	unless (null rs) $ do
 		void $ alertWhile (syncAlert rs) $
 			xmppReceivePack cid (handleDeferred checkcloudrepos)