workaround for Google Talk's insane handling of self-directed presence

Maybe the spec allows it, but broadcasting self-directed presence info to
all buddies is just insane.

I had to bring back the IQ messages for self-pairing, while still using
directed presence for other pairing. Ugly.

Assistant/Threads/XMPPClient.hs

@@ -58,32 +58,32 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
  		 - if it keeps failing, back off to wait 5 minutes before
  		 - trying it again. -}
 		loop c starttime = do
-			runclient c
+			e <- runclient c
 			now <- getCurrentTime
 			if diffUTCTime now starttime > 300
 				then do
-					void $ iodebug ["connection lost; reconnecting"]
+					void $ iodebug ["connection lost; reconnecting", show e]
 					loop c now
 				else do
-					void $ iodebug ["connection failed; will retry"]
+					void $ iodebug ["connection failed; will retry", show e]
 					threadDelaySeconds (Seconds 300)
 					loop c =<< getCurrentTime
 
 		runclient c = void $ connectXMPP c $ \jid -> do
-			fulljid <- bindJID jid
-			debug' ["connected", show fulljid]
+			selfjid <- bindJID jid
+			debug' ["connected", show selfjid]
 			{- The buddy list starts empty each time
 			 - the client connects, so that stale info
 			 - is not retained. -}
 			void $ liftIO ioemptybuddies
 			putStanza $ gitAnnexPresence gitAnnexSignature
-			xmppThread $ receivenotifications fulljid
+			xmppThread $ receivenotifications selfjid
 			forever $ do
-				a <- liftIO $ iorelay fulljid
+				a <- liftIO $ iorelay selfjid
 				a
 
-		receivenotifications fulljid = forever $ do
-			l <- decodeStanza fulljid <$> getStanza
+		receivenotifications selfjid = forever $ do
+			l <- decodeStanza selfjid <$> getStanza
 			debug' ["received:", show l]
 			mapM_ handle l
 
@@ -95,6 +95,8 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
 			void $ liftIO $ iopull us
 		handle (GotNetMessage (PairingNotification stage t u)) =
 			maybe noop (handlePairing stage u) (parseJID t)
+		handle (GotNetMessage (SelfPairingNotification stage t u)) =
+			error "TODO"
 		handle (Ignorable _) = noop
 		handle (Unknown _) = noop
 		handle (ProtocolError _) = noop
@@ -113,10 +115,10 @@ data XMPPEvent
 
 {- Decodes an XMPP stanza into one or more events. -}
 decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
-decodeStanza fulljid s@(ReceivedPresence p)
+decodeStanza selfjid s@(ReceivedPresence p)
 	| presenceType p == PresenceError = [ProtocolError s]
 	| presenceFrom p == Nothing = [Ignorable p]
-	| presenceFrom p == Just fulljid = [Ignorable p]
+	| presenceFrom p == Just selfjid = [Ignorable p]
 	| not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed
 	| isPresenceQuery p = impliedp $ GotNetMessage QueryPresence
 	| otherwise = case decodePairingNotification p of
@@ -128,18 +130,27 @@ decodeStanza fulljid s@(ReceivedPresence p)
 	impliedp v = [PresenceMessage p, v]
 	pushed = concat $ catMaybes $ map decodePushNotification $
 		presencePayloads p
+decodeStanza _ s@(ReceivedIQ iq)
+	| iqType iq == IQError = [ProtocolError s]
+	| otherwise = case decodeSelfPairingNotification iq of
+		Nothing -> [Unknown s]
+		Just pn -> [GotNetMessage pn]
 decodeStanza _ s = [Unknown s]
 
 {- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
 relayNetMessage :: JID -> Assistant (XMPP ())
-relayNetMessage fulljid = convert <$> waitNetMessage
+relayNetMessage selfjid = convert <$> waitNetMessage
   where
 	convert (NotifyPush us) = putStanza $ pushNotification us
 	convert QueryPresence = putStanza $ presenceQuery
 	convert (PairingNotification stage t u) = case parseJID t of
 		Nothing -> noop
 		Just tojid -> mapM_ putStanza $
-			pairingNotification stage u tojid fulljid
+			encodePairingNotification stage u tojid selfjid
+	convert (SelfPairingNotification stage t u) = case parseJID t of
+		Nothing -> noop
+		Just tojid -> putStanza $
+			encodeSelfPairingNotification stage u tojid selfjid
 
 {- Runs the client, handing restart events. -}
 restartableClient :: IO () -> Assistant ()

Assistant/Types/NetMessager.hs

@@ -21,8 +21,11 @@ data NetMessage
 	-- requests other clients to inform us of their presence
 	| QueryPresence
 	-- notification about a stage in the pairing process,
-	-- involving another client identified by the Text, and a UUID.
+	-- involving a client identified by the Text, and a UUID.
 	| PairingNotification PairStage Text UUID
+	-- notification about a stage in the pairing process with
+	-- other clients using the same account.
+	| SelfPairingNotification PairStage Text UUID
 	deriving (Show)
 
 data NetMessagerControl = NetMessagerControl

Assistant/WebApp/Configurators/Pairing.hs

@@ -29,6 +29,7 @@ import Utility.Network
 import Annex.UUID
 #endif
 #ifdef WITH_XMPP
+import Assistant.XMPP
 import Assistant.XMPP.Client
 import Assistant.XMPP.Buddies
 import Network.Protocol.XMPP
@@ -88,16 +89,17 @@ getStartXMPPPairR bid = do
 		Nothing -> redirect StartPairR
 		(Just []) -> redirect StartPairR
 		(Just clients@((Client exemplar):_)) -> do
-			let samejid = basejid ourjid == basejid exemplar
-			let account = formatJID $ basejid exemplar
+			let samejid = baseJID ourjid == baseJID exemplar
+			let account = formatJID $ baseJID exemplar
 			liftAssistant $ do
 				u <- liftAnnex getUUID
-				sendNetMessage $ PairingNotification PairReq account u
+				if samejid
+					then forM_ clients $ \(Client c) ->
+						sendNetMessage $ SelfPairingNotification PairReq (formatJID c) u
+					else sendNetMessage $ PairingNotification PairReq account u
 			pairPage $ do
 				let name = buddyName exemplar
 				$(widgetFile "configurators/pairing/xmpp/inprogress")
-  where
-	basejid j = JID (jidNode j) (jidDomain j) Nothing
 #else
 getStartXMPPPairR _ = noXMPPPairing
 

Assistant/XMPP.hs

@@ -105,8 +105,8 @@ isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
  - PairDone, that resending is a desirable feature, as it helps ensure
  - clients see them.
  -}
-pairingNotification :: PairStage -> UUID -> JID -> JID -> [Presence]
-pairingNotification pairstage u tojid fromjid
+encodePairingNotification :: PairStage -> UUID -> JID -> JID -> [Presence]
+encodePairingNotification pairstage u tojid fromjid
 	| pairstage == PairReq = [send, clear]
 	| otherwise = [send]
 	where
@@ -115,23 +115,54 @@ pairingNotification pairstage u tojid fromjid
 		clear = directed $ gitAnnexPresence gitAnnexSignature
 
 		directed p = p
-			{ presenceTo = Just $ JID (jidNode tojid) (jidDomain tojid) Nothing
+			{ presenceTo = Just $ baseJID tojid
 			, presenceFrom = Just fromjid
 			}	
 
-		content = T.unwords
-			[ T.pack $ show pairstage
-			, T.pack $ fromUUID u
-			]
+		content = mkPairingContent pairstage u
+
+{- A notification about a stage of pairing. Sent to self as an XMPP IQ.
+ - Directed presence is not used for self-messaging presence because
+ - some XMPP clients seem very confused by it. Google Talk has been
+ - observed leaking self-directed presence to other friends, seeming
+ - to think it sets the visible presence.
+ - 
+ - The pairing info is sent using its id attribute; it also has a git-annex
+ - tag to identify it as from us. -}
+encodeSelfPairingNotification :: PairStage -> UUID -> JID -> JID -> IQ
+encodeSelfPairingNotification pairstage u tojid fromjid = (emptyIQ IQGet)
+	{ iqTo = Just tojid
+	, iqFrom = Just fromjid
+	, iqID = Just $ mkPairingContent pairstage u
+	, iqPayload = Just gitAnnexSignature
+	}
 
 decodePairingNotification :: Presence -> Maybe NetMessage
 decodePairingNotification p = case filter isGitAnnexTag (presencePayloads p) of
 	[] -> Nothing
-	(elt:_) -> parse =<< words . T.unpack <$> getAttr elt pairAttr
+	(elt:_) -> parsePairingContent (presenceFrom p) =<< getAttr elt pairAttr
+
+decodeSelfPairingNotification :: IQ -> Maybe NetMessage
+decodeSelfPairingNotification iq@(IQ { iqPayload = Just elt })
+	| isGitAnnexTag elt = parsePairingContent (iqFrom iq) =<< iqID iq
+	| otherwise = Nothing
+decodeSelfPairingNotification _ = Nothing
+
+mkPairingContent :: PairStage -> UUID -> T.Text
+mkPairingContent pairstage u = T.unwords $ map T.pack
+	[ show pairstage
+	, fromUUID u
+	]
+
+parsePairingContent :: Maybe JID -> T.Text -> Maybe NetMessage
+parsePairingContent jid t = parse $ words $ T.unpack t
   where
-	parse [stage, u] = 
-		PairingNotification
-			<$> readish stage
-			<*> (formatJID <$> presenceFrom p)
-			<*> pure (toUUID u)
+	parse [stage, u] = PairingNotification
+		<$> readish stage
+		<*> (formatJID <$> jid)
+		<*> pure (toUUID u)
 	parse _ = Nothing
+
+{- The JID without the client part. -}
+baseJID :: JID -> JID
+baseJID j = JID (jidNode j) (jidDomain j) Nothing

Assistant/XMPP/Buddies.hs

@@ -18,7 +18,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 
 genKey :: JID -> BuddyKey
-genKey j = BuddyKey $ formatJID $ JID (jidNode j) (jidDomain j) Nothing
+genKey j = BuddyKey $ formatJID $ baseJID j
 
 buddyName :: JID -> Text
 buddyName j = maybe (T.pack "") strNode (jidNode j)

doc/design/assistant/xmpp.mdwn

@@ -44,6 +44,11 @@ For pairing, a directed presence message is sent, also using the git-annex tag:
 
 	<git-annex xmlns='git-annex' pairing="PairReq uuid" />
 
+For pairing with other clients using the same XMPP account, git-annex uses
+IQ messages, also containing a git-annex tag. The id attribute of the iq
+tag contains the pairing information. This is done because self-directed
+presence is not handled correctly by Google Talk. (Or is ill-specified.)
+
 ### security
 
 Data git-annex sends over XMPP will be visible to the XMPP