switch to silent chat messages for XMPP pairing

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

4 files changed, 112 insertions, 141 deletions

diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 4f41fdb30..0836fa0f6 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/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
-	| isPresenceQuery p = impliedp $ GotNetMessage QueryPresence
-	| otherwise = case decodePairingNotification p of
-		Nothing -> [PresenceMessage p]
-		Just pn -> impliedp $ GotNetMessage pn
+	| otherwise = maybe [PresenceMessage p] decode (getGitAnnexAttrValue p)
   where
-	-- Things sent via presence imply a presence message,
-	-- along with their real meaning.
+	decode (attr, v)
+		| 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 $
-		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@(ReceivedMessage m)
+	| messageType m == MessageError = [ProtocolError s]
+	| otherwise = maybe [Unknown s] decode (getGitAnnexAttrValue m)
+  where
+	decode (attr, v)
+		| attr == pairAttr = 
+			[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 $
-			encodePairingNotification stage u tojid selfjid
-	convert (SelfPairingNotification stage t u) = case parseJID t of
-		Nothing -> noop
-		Just tojid -> putStanza $
-			encodeSelfPairingNotification stage u tojid selfjid
+		Just tojid
+			| tojid == selfjid -> noop
+			| otherwise -> putStanza $
+				pairingNotification stage u tojid selfjid
 
 {- Runs the client, handing restart events. -}
 restartableClient :: IO () -> Assistant ()
diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
index 3df1782f8..f84247d6c 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/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
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index e3013a92f..37cf00374 100644
--- a/Assistant/XMPP.hs
+++ b/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. -}
-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.
+{- Name of the 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. -}
-gitAnnexSignature :: Element
-gitAnnexSignature = Element gitAnnexTagName [] []
+{- Things that a git-annex tag can inserted into. -}
+class GitAnnexTaggable a where
+	insertGitAnnexTag :: a -> Element -> a
 
-queryAttr :: Name
-queryAttr = Name (T.pack "query") Nothing Nothing
+	extractGitAnnexTag :: a -> Maybe Element
 
-pushAttr :: Name
-pushAttr = Name (T.pack "push") Nothing Nothing
+	hasGitAnnexTag :: a -> Bool
+	hasGitAnnexTag = isJust . extractGitAnnexTag
 
-pairAttr :: Name
-pairAttr = Name (T.pack "pair") Nothing Nothing
+instance GitAnnexTaggable Message where
+	insertGitAnnexTag m e = m { messagePayloads = e : messagePayloads m }
+	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads
 
-isAttr :: Name -> (Name, [Content]) -> Bool
-isAttr attr (k, _) = k == attr
+instance GitAnnexTaggable Presence where
+	-- always mark extended away
+	insertGitAnnexTag p e = p { presencePayloads = extendedAway : e : presencePayloads p }
+	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads
 
-getAttr :: Element -> Name -> Maybe T.Text
-getAttr (Element _name attrs _nodes) name =
-	T.concat . map unpack . snd <$> headMaybe (filter (isAttr name) attrs)
+{- Gets the attr and value from a git-annex tag. -}
+getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, Text)
+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
 
-uuidSep :: T.Text
-uuidSep = T.pack ","
+{- A presence with a git-annex tag in it. -}
+gitAnnexPresence :: Element -> Presence
+gitAnnexPresence = insertGitAnnexTag $ emptyPresence PresenceAvailable
 
-{- git-annex tag with one push attribute per UUID pushed to. -}
-encodePushNotification :: [UUID] -> Element
-encodePushNotification us = Element gitAnnexTagName
-	[(pushAttr, [ContentText pushvalue])] []
-  where
-	pushvalue = T.intercalate uuidSep $
-		map (T.pack . fromUUID) us
+{- 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 [] []
 
-decodePushNotification :: Element -> Maybe [UUID]
-decodePushNotification (Element name attrs _nodes)
-	| 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
+{- 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 . encodePushNotification
+pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification
+
+pushAttr :: Name
+pushAttr = Name (T.pack "push") Nothing Nothing
+
+uuidSep :: T.Text
+uuidSep = T.pack ","
+
+encodePushNotification :: [UUID] -> Text
+encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)
+
+decodePushNotification :: Text -> [UUID]
+decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep
 
 {- A request for other git-annex clients to send presence. -}
 presenceQuery :: Presence
-presenceQuery = gitAnnexPresence $ Element gitAnnexTagName
-	[ (queryAttr, [ContentText T.empty]) ]
-	[]
+presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty
+
+queryAttr :: Name
+queryAttr = Name (T.pack "query") Nothing Nothing
 
-isPresenceQuery :: Presence -> Bool
-isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
-	[] -> False
-	((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs
+{- A notification about a stage of pairing. -}
+pairingNotification :: PairStage -> UUID -> JID -> JID -> Message
+pairingNotification pairstage u tojid fromjid =
+	(gitAnnexMessage tag)
+		{ messageTo = Just tojid
+		, messageFrom = Just fromjid
+		}
+  where
+	tag = gitAnnexTag pairAttr $
+		encodePairingNotification pairstage u
 
-{- A notification about a stage of pairing, sent as directed presence
- - to all clients of a jid. 
- -
- - For PairReq, the directed presence is followed by a second presence
- - without the pair notification. This is done because XMPP servers
- - resend the last directed presence periodically, which can make
- - 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
-			[(pairAttr, [ContentText content])] []
-		clear = directed $ gitAnnexPresence gitAnnexSignature
-
-		directed p = p
-			{ presenceTo = Just $ baseJID tojid
-			, presenceFrom = Just fromjid
-			}	
-
-		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:_) -> 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
+pairAttr :: Name
+pairAttr = Name (T.pack "pair") Nothing Nothing
+
+encodePairingNotification :: PairStage -> UUID -> Text
+encodePairingNotification 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
+decodePairingNotification :: Text -> Message -> Maybe NetMessage
+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"]
diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs
index 77e506ee9..fe5d8c6a9 100644
--- a/Assistant/XMPP/Buddies.hs
+++ b/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