finished XMPP pairing!

This includes keeping track of which buddies we're pairing with, to know
which PairAck are legitimate.

Annex/UUID.hs

@@ -18,6 +18,7 @@ module Annex.UUID (
 	prepUUID,
 	genUUID,
 	removeRepoUUID,
+	storeUUID,
 ) where
 
 import Common.Annex

Assistant/Alert.hs

@@ -317,7 +317,7 @@ pairRequestReceivedAlert who button = Alert
 
 pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
 pairRequestAcknowledgedAlert who button = baseActivityAlert
-	{ alertData = ["Pair request with", UnTensed (T.pack who), Tensed "in progress" "complete"]
+	{ alertData = ["Pairing with", UnTensed (T.pack who), Tensed "in progress" "complete"]
 	, alertPriority = High
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertButton = button

Assistant/Pairing/MakeRemote.hs

@@ -26,10 +26,10 @@ setupAuthorizedKeys msg repodir = do
   where
 	pubkey = remoteSshPubKey $ pairMsgData msg
 
-{- When pairing is complete, this is used to set up the remote for the host
- - we paired with. -}
-finishedPairing :: PairMsg -> SshKeyPair -> Assistant ()
-finishedPairing msg keypair = do
+{- When local pairing is complete, this is used to set up the remote for
+ - the host we paired with. -}
+finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()
+finishedLocalPairing msg keypair = do
 	sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg
 	{- Ensure that we know the ssh host key for the host we paired with.
 	 - If we don't, ssh over to get it. -}

Assistant/Threads/PairListener.hs

@@ -123,7 +123,7 @@ pairAckReceived True (Just pip) msg cache = do
 	stopSending pip
 	repodir <- repoPath <$> liftAnnex gitRepo
 	liftIO $ setupAuthorizedKeys msg repodir
-	finishedPairing msg (inProgressSshKeyPair pip)
+	finishedLocalPairing msg (inProgressSshKeyPair pip)
 	startSending pip PairDone $ multicastPairMsg
 		(Just 1) (inProgressSecret pip) (inProgressPairData pip)
 	return $ pip : take 10 cache
@@ -153,4 +153,4 @@ pairDoneReceived False _ _ = noop -- not verified
 pairDoneReceived True Nothing _ = noop -- not in progress
 pairDoneReceived True (Just pip) msg = do
 	stopSending pip
-	finishedPairing msg (inProgressSshKeyPair pip)
+	finishedLocalPairing msg (inProgressSshKeyPair pip)

Assistant/Threads/XMPPClient.hs

@@ -22,11 +22,14 @@ import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.Alert
 import Assistant.Pairing
+import Assistant.XMPP.Git
+import Annex.UUID
 
 import Network.Protocol.XMPP
 import Control.Concurrent
 import qualified Data.Text as T
 import qualified Data.Set as S
+import qualified Data.Map as M
 import qualified Git.Branch
 import Data.Time.Clock
 
@@ -36,17 +39,17 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
 	 - can be run from within the XMPP monad using liftIO. Ugly. -}
 	iodebug <- asIO1 debug
 	iopull <- asIO1 pull
-	iopairReqReceived <- asIO2 $ pairReqReceived urlrenderer
+	iopairMsgReceived <- asIO2 $ pairMsgReceived urlrenderer
 	ioupdatebuddies <- asIO1 $ \p ->
 		updateBuddyList (updateBuddies p) <<~ buddyList
 	ioemptybuddies <- asIO $
 		updateBuddyList (const noBuddies) <<~ buddyList
 	iorelay <- asIO1 relayNetMessage
 	ioclientthread <- asIO $
-		go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived
+		go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived
 	restartableClient ioclientthread
   where
-	go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived = do
+	go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived = do
 		v <- liftAnnex getXMPPCreds
 		case v of
 			Nothing -> noop
@@ -85,23 +88,19 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
 		receivenotifications selfjid = forever $ do
 			l <- decodeStanza selfjid <$> getStanza
 			debug' ["received:", show l]
-			mapM_ handle l
+			mapM_ (handle selfjid) l
 
-		handle (PresenceMessage p) =
+		handle _ (PresenceMessage p) =
 			void $ liftIO $ ioupdatebuddies p
-		handle (GotNetMessage QueryPresence) =
+		handle _ (GotNetMessage QueryPresence) =
 			putStanza gitAnnexSignature
-		handle (GotNetMessage (NotifyPush us)) =
+		handle _ (GotNetMessage (NotifyPush us)) =
 			void $ liftIO $ iopull us
-		handle (GotNetMessage (PairingNotification stage t u)) =
-			maybe noop (handlePairing stage u) (parseJID t)
-		handle (Ignorable _) = noop
-		handle (Unknown _) = noop
-		handle (ProtocolError _) = noop
-
-		handlePairing PairReq u jid = liftIO $ iopairReqReceived u jid
-		handlePairing PairAck _ _ = error "TODO"
-		handlePairing PairDone _ _ = error "TODO"
+		handle selfjid (GotNetMessage (PairingNotification stage t u)) =
+			maybe noop (\jid -> liftIO $ iopairMsgReceived (stage, u) (selfjid, jid)) (parseJID t)
+		handle _ (Ignorable _) = noop
+		handle _ (Unknown _) = noop
+		handle _ (ProtocolError _) = noop
 
 data XMPPEvent
 	= GotNetMessage NetMessage
@@ -139,16 +138,18 @@ decodeStanza _ s = [Unknown s]
 
 {- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
 relayNetMessage :: JID -> Assistant (XMPP ())
-relayNetMessage selfjid = convert <$> waitNetMessage
+relayNetMessage selfjid = convert =<< waitNetMessage
   where
-	convert (NotifyPush us) = putStanza $ pushNotification us
-	convert QueryPresence = putStanza $ presenceQuery
+	convert (NotifyPush us) = return $ putStanza $ pushNotification us
+	convert QueryPresence = return $ putStanza $ presenceQuery
 	convert (PairingNotification stage t u) = case parseJID t of
-		Nothing -> noop
+		Nothing -> return $ noop
 		Just tojid
-			| tojid == selfjid -> noop
-			| otherwise -> putStanza $
-				pairingNotification stage u tojid selfjid
+			| tojid == selfjid -> return $ noop
+			| otherwise -> do
+				changeBuddyPairing tojid True
+				return $ putStanza $
+					pairingNotification stage u tojid selfjid
 
 {- Runs the client, handing restart events. -}
 restartableClient :: IO () -> Assistant ()
@@ -193,17 +194,44 @@ pull us = do
 		unlessM (all id . fst <$> manualPull branch [r]) $
 			pullone rs branch
 
-{- Show an alert when a PairReq is seen, unless the PairReq came from
- - another client using our JID. In that case, just start pairing. -}
-pairReqReceived :: UrlRenderer -> UUID -> JID -> Assistant ()
-pairReqReceived urlrenderer u jid = do
-	-- TODO: check same JID
-	let route = FinishXMPPPairR (PairKey u $ formatJID jid)
-	url <- liftIO $ renderUrl urlrenderer route []
-	close <- asIO1 removeAlert
-	void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName jid)
-		AlertButton
-			{ buttonUrl = url
-			, buttonLabel = T.pack "Respond"
-			, buttonAction = Just close
-			}
+pairMsgReceived :: UrlRenderer -> (PairStage, UUID) -> (JID, JID) -> Assistant ()
+pairMsgReceived urlrenderer (PairReq, theiruuid) (selfjid, theirjid)
+	-- PairReq from another client using our JID is automatically accepted.
+	| baseJID selfjid == baseJID theirjid = do
+		selfuuid <- liftAnnex getUUID
+		sendNetMessage $
+			PairingNotification PairAck (formatJID theirjid) selfuuid
+		finishXMPPPairing theirjid theiruuid
+	-- Show an alert to let the user decide if they want to pair.
+	| otherwise = do
+		let route = FinishXMPPPairR (PairKey theiruuid $ formatJID theirjid)
+		url <- liftIO $ renderUrl urlrenderer route []
+		close <- asIO1 removeAlert
+		void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName theirjid)
+			AlertButton
+				{ buttonUrl = url
+				, buttonLabel = T.pack "Respond"
+				, buttonAction = Just close
+				}
+pairMsgReceived _ (PairAck, theiruuid) (_selfjid, theirjid) =
+	{- PairAck must come from one of the buddies we are pairing with;
+	 - don't pair with just anyone. -}
+	whenM (isBuddyPairing theirjid) $ do
+		changeBuddyPairing theirjid False
+		selfuuid <- liftAnnex getUUID
+		sendNetMessage $
+			PairingNotification PairDone (formatJID theirjid) selfuuid
+		finishXMPPPairing theirjid theiruuid
+pairMsgReceived _ (PairDone, _theiruuid) (_selfjid, theirjid) =
+	changeBuddyPairing theirjid False
+
+isBuddyPairing :: JID -> Assistant Bool
+isBuddyPairing jid = maybe False buddyPairing <$> 
+	getBuddy (genBuddyKey jid) <<~ buddyList
+
+changeBuddyPairing :: JID -> Bool -> Assistant ()
+changeBuddyPairing jid ispairing =
+	updateBuddyList (M.adjust set key) <<~ buddyList
+  where
+	key = genBuddyKey jid
+	set b = b { buddyPairing = ispairing }

Assistant/Types/Buddies.hs

@@ -32,6 +32,7 @@ data Buddy = Buddy
 	{ buddyPresent :: S.Set Client
 	, buddyAway :: S.Set Client
 	, buddyAssistants :: S.Set Client
+	, buddyPairing :: Bool
 	}
 #else
 data Buddy = Buddy

Assistant/WebApp/Configurators/Pairing.hs

@@ -32,6 +32,7 @@ import Annex.UUID
 import Assistant.XMPP
 import Assistant.XMPP.Client
 import Assistant.XMPP.Buddies
+import Assistant.XMPP.Git
 import Network.Protocol.XMPP
 import Assistant.Types.NetMessager
 import Assistant.NetMessager
@@ -139,9 +140,15 @@ getFinishLocalPairR _ = noLocalPairing
 
 getFinishXMPPPairR :: PairKey -> Handler RepHtml
 #ifdef WITH_XMPP
-getFinishXMPPPairR (PairKey u t) = case parseJID t of
+getFinishXMPPPairR (PairKey theiruuid t) = case parseJID t of
 	Nothing -> error "bad JID"
-	Just jid -> error "TODO"
+	Just theirjid -> do
+		liftAssistant $ do
+			selfuuid <- liftAnnex getUUID
+			sendNetMessage $
+				PairingNotification PairAck (formatJID theirjid) selfuuid
+			finishXMPPPairing theirjid theiruuid
+		redirect RepositoriesR
 #else
 getFinishXMPPPairR _ _ = noXMPPPairing
 #endif

Assistant/XMPP/Buddies.hs

@@ -17,8 +17,8 @@ import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 
-genKey :: JID -> BuddyKey
-genKey j = BuddyKey $ formatJID $ baseJID j
+genBuddyKey :: JID -> BuddyKey
+genBuddyKey j = BuddyKey $ formatJID $ baseJID j
 
 buddyName :: JID -> Text
 buddyName j = maybe (T.pack "") strNode (jidNode j)
@@ -28,7 +28,7 @@ buddyName j = maybe (T.pack "") strNode (jidNode j)
  - If the buddy has no clients at all anymore, returns Nothing. -}
 buddySummary :: Buddy -> Maybe (Text, Bool, Bool, BuddyKey)
 buddySummary b = case clients of
-	((Client j):_) -> Just (buddyName j, away, canpair, genKey j)
+	((Client j):_) -> Just (buddyName j, away, canpair, genBuddyKey j)
 	[] -> Nothing
   where
 	away = S.null (buddyPresent b) && S.null (buddyAssistants b)
@@ -39,7 +39,7 @@ buddySummary b = case clients of
 updateBuddies :: Presence -> Buddies -> Buddies
 updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key
   where
-	key = genKey jid
+	key = genBuddyKey jid
 	update (Just b) = Just $ applyPresence p b
 	update Nothing = newBuddy p
 updateBuddies _ = id
@@ -56,6 +56,7 @@ newBuddy p
 		{ buddyPresent = S.empty
 		, buddyAway = S.empty
 		, buddyAssistants = S.empty
+		, buddyPairing = False
 		}
 
 applyPresence :: Presence -> Buddy -> Buddy

Assistant/XMPP/Git.hs

@@ -0,0 +1,49 @@
+{- git over XMPP
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.XMPP.Git where
+
+import Assistant.Common
+import Assistant.XMPP
+import Assistant.XMPP.Buddies
+import Assistant.DaemonStatus
+import Assistant.Alert
+import Assistant.MakeRemote
+import Assistant.Sync
+import Annex.UUID
+import Config
+import qualified Types.Remote as Remote
+
+import Network.Protocol.XMPP
+import qualified Data.Text as T
+
+finishXMPPPairing :: JID -> UUID -> Assistant ()
+finishXMPPPairing jid u = void $ alertWhile alert $
+	makeXMPPGitRemote buddy (baseJID jid) u
+  where
+	buddy = T.unpack $ buddyName jid
+	alert = pairRequestAcknowledgedAlert buddy Nothing
+
+{- A git remote for an XMPP user? This is represented as a git remote
+ - that has no location set. The user's XMPP address is stored in the
+ - xmppaddress setting.
+ -
+ - The UUID of their remote is also stored as usual.
+ -}
+makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
+makeXMPPGitRemote buddyname jid u = do
+	remote <- liftAnnex $ addRemote $ makeGitRemote buddyname "" -- no location
+	liftAnnex $ do
+		let r = Remote.repo remote
+		storeUUID (remoteConfig r "uuid") u
+		setConfig (remoteConfig r "xmppaddress") xmppaddress
+	syncNewRemote remote
+	return True
+  where
+	xmppaddress = T.unpack $ formatJID $ baseJID jid
+
+

doc/git-annex.mdwn

@@ -881,6 +881,11 @@ Here are all the supported configuration settings.
   Used to identify Amazon S3 special remotes.
   Normally this is automaticaly set up by `git annex initremote`.
 
+* `remote.<name>.annex-xmppaddress`
+
+  Used to identify the XMPP address of a Jabber buddy.
+  Normally this is set up by the git-annex assistant when pairing over XMPP.
+
 # CONFIGURATION VIA .gitattributes
 
 The key-value backend used when adding a new file to the annex can be