switch to silent chat messages for XMPP pairing

Along the way, significantly cleaned up Assistant.XMPP, and made XMPP
message decoding more efficient.

Assistant/Threads/XMPPClient.hs

@@ -76,7 +76,7 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
 			 - the client connects, so that stale info
 			 - is not retained. -}
 			void $ liftIO ioemptybuddies
-			putStanza $ gitAnnexPresence gitAnnexSignature
+			putStanza gitAnnexSignature
 			xmppThread $ receivenotifications selfjid
 			forever $ do
 				a <- liftIO $ iorelay selfjid
@@ -90,13 +90,11 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
 		handle (PresenceMessage p) =
 			void $ liftIO $ ioupdatebuddies p
 		handle (GotNetMessage QueryPresence) =
-			putStanza $ gitAnnexPresence gitAnnexSignature
+			putStanza gitAnnexSignature
 		handle (GotNetMessage (NotifyPush us)) =
 			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
@@ -119,22 +117,24 @@ decodeStanza selfjid s@(ReceivedPresence p)
 	| presenceType p == PresenceError = [ProtocolError s]
 	| presenceFrom p == Nothing = [Ignorable p]
 	| presenceFrom p == Just selfjid = [Ignorable p]
-	| not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed
+	| otherwise = maybe [PresenceMessage p] decode (getGitAnnexAttrValue p)
-	| isPresenceQuery p = impliedp $ GotNetMessage QueryPresence
-	| otherwise = case decodePairingNotification p of
-		Nothing -> [PresenceMessage p]
-		Just pn -> impliedp $ GotNetMessage pn
   where
-	-- Things sent via presence imply a presence message,
+	decode (attr, v)
-	-- along with their real meaning.
+		| attr == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
+			decodePushNotification v
+		| attr == queryAttr = impliedp $ GotNetMessage QueryPresence
+		| otherwise = [Unknown s]
+	{- Things sent via presence imply a presence message,
+	 - along with their real meaning. -}
 	impliedp v = [PresenceMessage p, v]
-	pushed = concat $ catMaybes $ map decodePushNotification $
+decodeStanza _ s@(ReceivedMessage m)
-		presencePayloads p
+	| messageType m == MessageError = [ProtocolError s]
-decodeStanza _ s@(ReceivedIQ iq)
+	| otherwise = maybe [Unknown s] decode (getGitAnnexAttrValue m)
-	| iqType iq == IQError = [ProtocolError s]
+  where
-	| otherwise = case decodeSelfPairingNotification iq of
+	decode (attr, v)
-		Nothing -> [Unknown s]
+		| attr == pairAttr = 
-		Just pn -> [GotNetMessage pn]
+			[maybe (Unknown s) GotNetMessage (decodePairingNotification v m)]
+		| otherwise = [Unknown s]
 decodeStanza _ s = [Unknown s]
 
 {- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
@@ -145,12 +145,10 @@ relayNetMessage selfjid = convert <$> waitNetMessage
 	convert QueryPresence = putStanza $ presenceQuery
 	convert (PairingNotification stage t u) = case parseJID t of
 		Nothing -> noop
-		Just tojid -> mapM_ putStanza $
+		Just tojid
-			encodePairingNotification stage u tojid selfjid
+			| tojid == selfjid -> noop
-	convert (SelfPairingNotification stage t u) = case parseJID t of
+			| otherwise -> putStanza $
-		Nothing -> noop
+				pairingNotification stage u tojid selfjid
-		Just tojid -> putStanza $
-			encodeSelfPairingNotification stage u tojid selfjid
 
 {- Runs the client, handing restart events. -}
 restartableClient :: IO () -> Assistant ()

Assistant/Types/NetMessager.hs

@@ -23,9 +23,6 @@ data NetMessage
 	-- notification about a stage in the pairing process,
 	-- 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

@@ -81,26 +81,24 @@ getStartPairR = noPairing "local or jabber"
 getStartXMPPPairR :: BuddyKey -> Handler RepHtml
 #ifdef WITH_XMPP
 getStartXMPPPairR bid = do
+	buddy <- liftAssistant $ getBuddy bid <<~ buddyList
+	go $ S.toList . buddyAssistants <$> buddy
+  where
+	go (Just (clients@((Client exemplar):_))) = do
 		creds <- runAnnex Nothing getXMPPCreds
 		let ourjid = fromJust $ parseJID =<< xmppJID <$> creds
-	buddy <- liftAssistant $ getBuddy bid <<~ buddyList
-	case S.toList . buddyAssistants <$> buddy of
-		-- A buddy could have logged out, or the XMPP client restarted;
-		-- so handle unforseen by going back.
-		Nothing -> redirect StartPairR
-		(Just []) -> redirect StartPairR
-		(Just clients@((Client exemplar):_)) -> do
 		let samejid = baseJID ourjid == baseJID exemplar
 		let account = formatJID $ baseJID exemplar
 		liftAssistant $ do
 			u <- liftAnnex getUUID
-				if samejid
+			forM_ clients $ \(Client c) -> sendNetMessage $
-					then forM_ clients $ \(Client c) ->
+				PairingNotification PairReq (formatJID c) u
-						sendNetMessage $ SelfPairingNotification PairReq (formatJID c) u
-					else sendNetMessage $ PairingNotification PairReq account u
 		pairPage $ do
 			let name = buddyName exemplar
 			$(widgetFile "configurators/pairing/xmpp/inprogress")
+	-- A buddy could have logged out, or the XMPP client restarted,
+	-- and there be no clients to message; handle unforseen by going back.
+	go _ = redirect StartPairR
 #else
 getStartXMPPPairR _ = noXMPPPairing
 

Assistant/XMPP.hs

@@ -12,157 +12,133 @@ import Assistant.Types.NetMessager
 import Assistant.Pairing
 
 import Network.Protocol.XMPP
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.XML.Types
 
-{- A presence with a git-annex tag in it. -}
+{- Name of the git-annex tag, in our own XML namespace.
-gitAnnexPresence :: Element -> Presence
-gitAnnexPresence tag = (emptyPresence PresenceAvailable)
-	{ presencePayloads = [extendedAway, tag] }
-  where
-	extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
-		[NodeContent $ ContentText $ T.pack "xa"]
-
-{- Does a presence contain a git-annex tag? -}
-isGitAnnexPresence :: Presence -> Bool
-isGitAnnexPresence p = any isGitAnnexTag (presencePayloads p)
-
-{- Name of a git-annex tag, in our own XML namespace.
  - (Not using a namespace URL to avoid unnecessary bloat.) -}
 gitAnnexTagName :: Name
 gitAnnexTagName  = Name (T.pack "git-annex") (Just $ T.pack "git-annex") Nothing
 
+{- Creates a git-annex tag containing a particular attribute and value. -}
+gitAnnexTag :: Name -> Text -> Element
+gitAnnexTag attr val = Element gitAnnexTagName [(attr, [ContentText val])] []
+
 isGitAnnexTag :: Element -> Bool
 isGitAnnexTag t = elementName t == gitAnnexTagName
 
-{- A git-annex tag, to let other clients know we're a git-annex client too. -}
+{- Things that a git-annex tag can inserted into. -}
-gitAnnexSignature :: Element
+class GitAnnexTaggable a where
-gitAnnexSignature = Element gitAnnexTagName [] []
+	insertGitAnnexTag :: a -> Element -> a
 
-queryAttr :: Name
+	extractGitAnnexTag :: a -> Maybe Element
-queryAttr = Name (T.pack "query") Nothing Nothing
 
-pushAttr :: Name
+	hasGitAnnexTag :: a -> Bool
-pushAttr = Name (T.pack "push") Nothing Nothing
+	hasGitAnnexTag = isJust . extractGitAnnexTag
 
-pairAttr :: Name
+instance GitAnnexTaggable Message where
-pairAttr = Name (T.pack "pair") Nothing Nothing
+	insertGitAnnexTag m e = m { messagePayloads = e : messagePayloads m }
+	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads
 
-isAttr :: Name -> (Name, [Content]) -> Bool
+instance GitAnnexTaggable Presence where
-isAttr attr (k, _) = k == attr
+	-- always mark extended away
+	insertGitAnnexTag p e = p { presencePayloads = extendedAway : e : presencePayloads p }
+	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads
 
-getAttr :: Element -> Name -> Maybe T.Text
+{- Gets the attr and value from a git-annex tag. -}
-getAttr (Element _name attrs _nodes) name =
+getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, Text)
-	T.concat . map unpack . snd <$> headMaybe (filter (isAttr name) attrs)
+getGitAnnexAttrValue a = case extractGitAnnexTag a of
+	Just (Element _ [(attr, content)] []) -> Just $
+		(attr, T.concat $ map unpack content)
+	_ -> Nothing
   where
 	unpack (ContentText t) = t
 	unpack (ContentEntity t) = t
 
+{- A presence with a git-annex tag in it. -}
+gitAnnexPresence :: Element -> Presence
+gitAnnexPresence = insertGitAnnexTag $ emptyPresence PresenceAvailable
+
+{- A presence with an empty git-annex tag in it, used for letting other
+ - clients know we're around and are a git-annex client. -}
+gitAnnexSignature :: Presence
+gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] []
+
+{- A message with a git-annex tag in it. -}
+gitAnnexMessage :: Element -> Message
+gitAnnexMessage = insertGitAnnexTag silentMessage
+
+{- A notification that we've pushed to some repositories, listing their
+ - UUIDs. -}
+pushNotification :: [UUID] -> Presence
+pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification
+
+pushAttr :: Name
+pushAttr = Name (T.pack "push") Nothing Nothing
+
 uuidSep :: T.Text
 uuidSep = T.pack ","
 
-{- git-annex tag with one push attribute per UUID pushed to. -}
+encodePushNotification :: [UUID] -> Text
-encodePushNotification :: [UUID] -> Element
+encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)
-encodePushNotification us = Element gitAnnexTagName
-	[(pushAttr, [ContentText pushvalue])] []
-  where
-	pushvalue = T.intercalate uuidSep $
-		map (T.pack . fromUUID) us
 
-decodePushNotification :: Element -> Maybe [UUID]
+decodePushNotification :: Text -> [UUID]
-decodePushNotification (Element name attrs _nodes)
+decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep
-	| name == gitAnnexTagName && not (null us) = Just us
-	| otherwise = Nothing
-  where
-	us = map (toUUID . T.unpack) $
-		concatMap (T.splitOn uuidSep . T.concat . map fromContent . snd) $
-		filter ispush attrs
-	ispush (k, _) = k == pushAttr
-	fromContent (ContentText t) = t
-	fromContent (ContentEntity t) = t
-
-pushNotification :: [UUID] -> Presence
-pushNotification = gitAnnexPresence . encodePushNotification
 
 {- A request for other git-annex clients to send presence. -}
 presenceQuery :: Presence
-presenceQuery = gitAnnexPresence $ Element gitAnnexTagName
+presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty
-	[ (queryAttr, [ContentText T.empty]) ]
-	[]
 
-isPresenceQuery :: Presence -> Bool
+queryAttr :: Name
-isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
+queryAttr = Name (T.pack "query") Nothing Nothing
-	[] -> False
-	((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs
 
-{- A notification about a stage of pairing, sent as directed presence
+{- A notification about a stage of pairing. -}
- - to all clients of a jid. 
+pairingNotification :: PairStage -> UUID -> JID -> JID -> Message
- -
+pairingNotification pairstage u tojid fromjid =
- - For PairReq, the directed presence is followed by a second presence
+	(gitAnnexMessage tag)
- - without the pair notification. This is done because XMPP servers
+		{ messageTo = Just tojid
- - resend the last directed presence periodically, which can make
+		, messageFrom = Just fromjid
- - the pair request alert be re-displayed annoyingly. For PairAck and
+		}
- - PairDone, that resending is a desirable feature, as it helps ensure
- - clients see them.
- -}
-encodePairingNotification :: PairStage -> UUID -> JID -> JID -> [Presence]
-encodePairingNotification pairstage u tojid fromjid
-	| pairstage == PairReq = [send, clear]
-	| otherwise = [send]
   where
-		send = directed $ gitAnnexPresence $ Element gitAnnexTagName
+	tag = gitAnnexTag pairAttr $
-			[(pairAttr, [ContentText content])] []
+		encodePairingNotification pairstage u
-		clear = directed $ gitAnnexPresence gitAnnexSignature
 
-		directed p = p
+pairAttr :: Name
-			{ presenceTo = Just $ baseJID tojid
+pairAttr = Name (T.pack "pair") Nothing Nothing
-			, presenceFrom = Just fromjid
-			}	
 
-		content = mkPairingContent pairstage u
+encodePairingNotification :: PairStage -> UUID -> Text
-
+encodePairingNotification pairstage u = T.unwords $ map T.pack
-{- 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:_) -> 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
+decodePairingNotification :: Text -> Message -> Maybe NetMessage
-parsePairingContent jid t = parse $ words $ T.unpack t
+decodePairingNotification t msg = parse $ words $ T.unpack t
   where
 	parse [stage, u] = PairingNotification
 		<$> readish stage
-		<*> (formatJID <$> jid)
+		<*> (formatJID <$> messageFrom msg)
 		<*> pure (toUUID u)
 	parse _ = Nothing
 
 {- The JID without the client part. -}
 baseJID :: JID -> JID
 baseJID j = JID (jidNode j) (jidDomain j) Nothing
+
+{- An XMPP chat message with an empty body. This should not be displayed
+ - by clients, but can be used for communications. -}
+silentMessage :: Message
+silentMessage = (emptyMessage MessageChat)
+	{ messagePayloads = [ emptybody ] }
+  where
+	emptybody = Element
+		{ elementName = Name (T.pack "body") Nothing Nothing
+		, elementAttributes = []
+		, elementNodes = []
+		}
+
+{- Add to a presence to mark its client as extended away. -}
+extendedAway :: Element
+extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
+	[NodeContent $ ContentText $ T.pack "xa"]

Assistant/XMPP/Buddies.hs

@@ -67,7 +67,7 @@ applyPresence p b = fromMaybe b $! go <$> presenceFrom p
 			, buddyPresent = removefrom $ buddyPresent b
 			, buddyAssistants = removefrom $ buddyAssistants b
 			}
-		| isGitAnnexPresence p = b
+		| hasGitAnnexTag p = b
 			{ buddyAssistants = addto $ buddyAssistants b
 			, buddyAway = removefrom $ buddyAway b }
 		| presenceType p == PresenceAvailable = b

doc/design/assistant/xmpp.mdwn

@@ -29,26 +29,26 @@ who share a repository, that is stored in the [[cloud]].
 ## protocol
 
 To avoid relying on XMPP extensions, git-annex communicates
-using presence messages. These always mark it as extended away.
+using presence messages (which always mark it as extended away),
-To this, it adds its own tag as [extended content](http://xmpp.org/rfcs/rfc6121.html#presence-extended).
+and chat messages (with empty body tags, so clients don't display them).
+
+To these messages, it adds its own tag as
+[extended content](http://xmpp.org/rfcs/rfc6121.html#presence-extended).
 The xml namespace is "git-annex" (not an URL because I hate wasting bandwidth).
 
-To indicate it's pushed changes to a git repo with a given UUID, a client uses:
+To indicate it's pushed changes to a git repo with a given UUID,
+a message that should be sent to all buddies and other clients using the account
+(no explicit pairing needed), a client uses a broadcast presence message with:
 
 	<git-annex xmlns='git-annex' push="uuid[,uuid...]" />
 
 Multiple UUIDs can be listed when multiple clients were pushed. If the
 git repo does not have a git-annex UUID, an empty string is used.
 
-For pairing, a directed presence message is sent, also using the git-annex tag:
+For pairing, a chat 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