XMPP pairing notifications are now sent

Rest of pairing process still to do.

4 files changed, 78 insertions, 66 deletions

diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 113bc06ab..6aeabb24b 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -33,7 +33,7 @@ xmppClientThread = NamedThread "XMPPClient" $ do
 		updateBuddyList (updateBuddies p) <<~ buddyList
 	ioemptybuddies <- asIO $
 		updateBuddyList (const noBuddies) <<~ buddyList
-	iorelay <- asIO relayNetMessage
+	iorelay <- asIO1 relayNetMessage
 	ioclientthread <- asIO $
 		go iorelay iodebug iopull ioupdatebuddies ioemptybuddies
 	restartableClient ioclientthread
@@ -45,6 +45,7 @@ xmppClientThread = NamedThread "XMPPClient" $ do
 			Just c -> liftIO $ loop c =<< getCurrentTime
 	  where
 		debug' = void . liftIO . iodebug
+
 		{- When the client exits, it's restarted;
  		 - if it keeps failing, back off to wait 5 minutes before
  		 - trying it again. -}
@@ -59,6 +60,7 @@ xmppClientThread = NamedThread "XMPPClient" $ do
 					void $ iodebug ["connection failed; will retry"]
 					threadDelaySeconds (Seconds 300)
 					loop c =<< getCurrentTime
+
 		runclient c = void $ connectXMPP c $ \jid -> do
 			fulljid <- bindJID jid
 			debug' ["connected", show fulljid]
@@ -69,47 +71,62 @@ xmppClientThread = NamedThread "XMPPClient" $ do
 			putStanza $ gitAnnexPresence gitAnnexSignature
 			xmppThread $ receivenotifications fulljid
 			forever $ do
-				a <- liftIO iorelay
+				a <- liftIO $ iorelay fulljid
 				a
+
 		receivenotifications fulljid = forever $ do
 			s <- getStanza
-			let v = decodeStanza fulljid s
-			debug' ["received:", show v]
-			case v of
-				PresenceMessage p -> void $ liftIO $ ioupdatebuddies p
-				PresenceQuery p -> do
-					void $ liftIO $ ioupdatebuddies p
-					putStanza $ gitAnnexPresence gitAnnexSignature
-				PushNotification us -> void $ liftIO $ iopull us
-				Ignorable _ -> noop
-				Unknown _ -> noop
+			let vs = decodeStanza fulljid s
+			debug' ["received:", show vs]
+			mapM_ handle vs
 
-{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
-relayNetMessage :: Assistant (XMPP ())
-relayNetMessage = convert <$> waitNetMessage
-  where
-	convert (NotifyPush us) = putStanza $ pushNotification us
-	convert QueryPresence = putStanza presenceQuery
+		handle (PresenceMessage p) =
+			void $ liftIO $ ioupdatebuddies p
+		handle (GotNetMessage QueryPresence) =
+			putStanza $ gitAnnexPresence gitAnnexSignature
+		handle (GotNetMessage (NotifyPush us)) =
+			void $ liftIO $ iopull us
+		handle (GotNetMessage (PairingNotification stage t u)) = case parseJID t of
+			Nothing -> noop
+			Just jid -> error "TODO"
+		handle (Ignorable _) = noop
+		handle (Unknown _) = noop
 
-data DecodedStanza 
-	= PresenceMessage Presence
-	| PresenceQuery Presence
-	| PushNotification [UUID]
+data XMPPEvent
+	= GotNetMessage NetMessage
+	| PresenceMessage Presence
 	| Ignorable Presence
 	| Unknown ReceivedStanza
 	deriving Show
 
-decodeStanza :: JID -> ReceivedStanza -> DecodedStanza
+{- Decodes an XMPP stanza into one or more events. -}
+decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
 decodeStanza fulljid (ReceivedPresence p)
-	| presenceFrom p == Nothing = Ignorable p
-	| presenceFrom p == Just fulljid = Ignorable p
-	| isPresenceQuery p = PresenceQuery p
-	| null pushed = PresenceMessage p
-	| otherwise = PushNotification pushed
+	| presenceFrom p == Nothing = [Ignorable p]
+	| presenceFrom p == Just fulljid = [Ignorable p]
+	| not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed
+	| isPresenceQuery p = impliedp $ GotNetMessage QueryPresence
+	| otherwise = [PresenceMessage p]
   where
+	-- Some things are sent via presence, so imply a presence message,
+	-- along with their real value.
+	impliedp v = [PresenceMessage p, v]
 	pushed = concat $ catMaybes $ map decodePushNotification $
 		presencePayloads p
-decodeStanza _ s = Unknown s
+decodeStanza _ s@(ReceivedIQ iq) = case decodePairingNotification 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
+  where
+	convert (NotifyPush us) = putStanza $ pushNotification us
+	convert QueryPresence = putStanza $ presenceQuery
+	convert (PairingNotification stage t u) = case parseJID t of
+		Nothing -> noop
+		Just tojid -> putStanza $ pairingNotification stage u tojid fulljid
 
 {- Runs the client, handing restart events. -}
 restartableClient :: IO () -> Assistant ()
diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
index 6bc9ec34a..79342b666 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/Assistant/Types/NetMessager.hs
@@ -8,7 +8,9 @@
 module Assistant.Types.NetMessager where
 
 import Common.Annex
+import Assistant.Pairing
 
+import Data.Text (Text)
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
 
@@ -18,12 +20,11 @@ data NetMessage
 	= NotifyPush [UUID]
 	-- 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.
+	| PairingNotification PairStage Text UUID
+	deriving (Show)
 
-{- Controls for the XMPP client. 
- -
- - It can be fed XMPP messages to send.
- -
- - It can also be sent a signal when it should restart for some reason. -}
 data NetMessagerControl = NetMessagerControl
 	{ netMessages :: TChan (NetMessage)
 	, netMessagerRestart :: MSampleVar ()
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 834055fbc..04eea50f6 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -8,7 +8,7 @@
 module Assistant.XMPP where
 
 import Assistant.Common
-import Annex.UUID
+import Assistant.Types.NetMessager
 import Assistant.Pairing
 
 import Network.Protocol.XMPP
@@ -45,22 +45,9 @@ queryAttr = Name (T.pack "query") Nothing Nothing
 pushAttr :: Name
 pushAttr = Name (T.pack "push") Nothing Nothing
 
-pairingAttr :: Name
-pairingAttr = Name (T.pack "pairing") Nothing Nothing
-
 isAttr :: Name -> (Name, [Content]) -> Bool
 isAttr attr (k, _) = k == attr
 
-getAttr :: Name -> [(Name, [Content])] -> Maybe String
-getAttr wantattr attrs = content <$> headMaybe (filter (isAttr wantattr) attrs)
-  where
-	content (_name, cs) = T.unpack $ T.concat $ map unpack cs
-	unpack (ContentText t) = t
-	unpack (ContentEntity t) = t
-
-uuidAttr :: Name
-uuidAttr = Name (T.pack "uuid") Nothing Nothing
-
 uuidSep :: T.Text
 uuidSep = T.pack ","
 
@@ -98,20 +85,25 @@ 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 -> Annex Presence
-pairingNotification pairstage = do
-	u <- getUUID
-	return $ gitAnnexPresence $ Element gitAnnexTagName
-		[ (pairingAttr, [ContentText $ T.pack $ show pairstage])
-		, (uuidAttr, [ContentText $ T.pack $ fromUUID u]) 
+{- A notification about a stage of pairing. Sent as an XMPP ping. 
+ - The pairing info is sent using its id attribute. -}
+pairingNotification :: PairStage -> UUID -> JID -> JID -> IQ
+pairingNotification pairstage u tojid fromjid = (emptyIQ IQGet)
+	{ iqTo = Just tojid
+	, iqFrom = Just fromjid
+	, iqID = Just $ T.unwords $ map T.pack
+		[ "git-annex"
+		, show pairstage
+		, fromUUID u
 		]
-		[]
-
-isPairingNotification :: Presence -> Maybe (PairStage, UUID)
-isPairingNotification p = case filter isGitAnnexTag (presencePayloads p) of
-	[] -> Nothing
-	((Element _name attrs _nodes):_) ->
-		(,)
-			<$> (readish =<< getAttr pairingAttr attrs)
-			<*> (toUUID <$> getAttr uuidAttr attrs)
+	}
+
+decodePairingNotification :: IQ -> Maybe NetMessage
+decodePairingNotification iq = parseid =<< words . T.unpack <$> iqID iq
+  where
+	parseid ["git-annex", stage, u] = 
+		PairingNotification
+			<$> readish stage
+			<*> (formatJID <$> iqFrom iq)
+			<*> pure (toUUID u)
+	parseid _ = Nothing
diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs
index 217870dc6..d784f316d 100644
--- a/Assistant/XMPP/Buddies.hs
+++ b/Assistant/XMPP/Buddies.hs
@@ -23,15 +23,17 @@ genBuddyID j = BuddyID $ formatJID j
 genKey :: JID -> BuddyKey
 genKey j = BuddyKey $ formatJID $ JID (jidNode j) (jidDomain j) Nothing
 
+buddyName :: JID -> Text
+buddyName j = maybe (T.pack "") strNode (jidNode j)
+
 {- Summary of info about a buddy.
  -
  - If the buddy has no clients at all anymore, returns Nothing. -}
 buddySummary :: Buddy -> Maybe (Text, Bool, Bool, BuddyID)
 buddySummary b = case clients of
-	((Client j):_) -> Just (buddyname j, away, canpair, genBuddyID j)
+	((Client j):_) -> Just (buddyName j, away, canpair, genBuddyID j)
 	[] -> Nothing
   where
-	buddyname j = maybe (T.pack "") strNode (jidNode j)
 	away = S.null (buddyPresent b) && S.null (buddyAssistants b)
 	canpair = not $ S.null (buddyAssistants b)
 	clients = S.toList $ buddyPresent b `S.union` buddyAway b `S.union` buddyAssistants b