XMPP pairing notifications are now sent

Rest of pairing process still to do.

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
+			let vs = decodeStanza fulljid s
-			debug' ["received:", show v]
+			debug' ["received:", show vs]
-			case v of
+			mapM_ handle vs
-				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
 
-{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
+		handle (PresenceMessage p) =
-relayNetMessage :: Assistant (XMPP ())
+			void $ liftIO $ ioupdatebuddies p
-relayNetMessage = convert <$> waitNetMessage
+		handle (GotNetMessage QueryPresence) =
-  where
+			putStanza $ gitAnnexPresence gitAnnexSignature
-	convert (NotifyPush us) = putStanza $ pushNotification us
+		handle (GotNetMessage (NotifyPush us)) =
-	convert QueryPresence = putStanza presenceQuery
+			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 
+data XMPPEvent
-	= PresenceMessage Presence
+	= GotNetMessage NetMessage
-	| PresenceQuery Presence
+	| PresenceMessage Presence
-	| PushNotification [UUID]
 	| 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 == Nothing = [Ignorable p]
-	| presenceFrom p == Just fulljid = Ignorable p
+	| presenceFrom p == Just fulljid = [Ignorable p]
-	| isPresenceQuery p = PresenceQuery p
+	| not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed
-	| null pushed = PresenceMessage p
+	| isPresenceQuery p = impliedp $ GotNetMessage QueryPresence
-	| otherwise = PushNotification pushed
+	| 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 ()

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 ()

Assistant/WebApp/Configurators/Pairing.hs

@@ -30,6 +30,7 @@ import Annex.UUID
 #endif
 #ifdef WITH_XMPP
 import Assistant.XMPP.Client
+import Assistant.XMPP.Buddies
 import Network.Protocol.XMPP
 import Assistant.Types.NetMessager
 import Assistant.NetMessager
@@ -50,8 +51,8 @@ import Control.Concurrent
 {- Starts either kind of pairing. -}
 getStartPairR :: Handler RepHtml
 #ifdef WITH_XMPP
-getStartPairR = pairPage $ do
+getStartPairR = do
-	xmppconfigured <- lift $ isJust <$> runAnnex Nothing getXMPPCreds
+	xmppconfigured <- isJust <$> runAnnex Nothing getXMPPCreds
 #ifdef WITH_PAIRING
 	let localsupported = True
 #else
@@ -59,8 +60,9 @@ getStartPairR = pairPage $ do
 #endif
 	{- Ask buddies to send presence info, to get the buddy list
 	 - populated. -}
-	lift $ liftAssistant $ sendNetMessage QueryPresence
+	liftAssistant $ sendNetMessage QueryPresence
-	$(widgetFile "configurators/pairing/start")
+	pairPage $
+		$(widgetFile "configurators/pairing/start")
 #else
 #ifdef WITH_PAIRING
 getStartPairR = redirect StartLocalPairR
@@ -69,12 +71,26 @@ getStartPairR = noPairing "local or jabber"
 #endif
 #endif
 
-{- Starts pairing with an XMPP buddy. -}
+{- Starts pairing with an XMPP buddy, or with other clients sharing an
+ - XMPP account. -}
 getStartXMPPPairR :: BuddyID -> Handler RepHtml
 #ifdef WITH_XMPP
 getStartXMPPPairR (BuddyID bid) = case parseJID bid of
 	Nothing -> error "bad JID"
-	Just jid -> error "TODO"
+	Just jid -> do
+		creds <- runAnnex Nothing getXMPPCreds
+		let ourjid = fromJust $ parseJID =<< xmppJID <$> creds
+		liftAssistant $ do
+			u <- liftAnnex getUUID
+			sendNetMessage $ PairingNotification
+				PairReq (formatJID jid) u
+		pairPage $ do
+			let samejid = equivjids jid ourjid
+			let account = formatJID jid
+			let name = buddyName jid
+			$(widgetFile "configurators/pairing/xmpp/inprogress")
+  where
+	equivjids a b = jidNode a == jidNode b && jidDomain a == jidDomain b
 #else
 getStartXMPPPairR _ = noPairing "XMPP"
 #endif

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. -}
+{- A notification about a stage of pairing. Sent as an XMPP ping. 
-pairingNotification :: PairStage -> Annex Presence
+ - The pairing info is sent using its id attribute. -}
-pairingNotification pairstage = do
+pairingNotification :: PairStage -> UUID -> JID -> JID -> IQ
-	u <- getUUID
+pairingNotification pairstage u tojid fromjid = (emptyIQ IQGet)
-	return $ gitAnnexPresence $ Element gitAnnexTagName
+	{ iqTo = Just tojid
-		[ (pairingAttr, [ContentText $ T.pack $ show pairstage])
+	, iqFrom = Just fromjid
-		, (uuidAttr, [ContentText $ T.pack $ fromUUID u]) 
+	, iqID = Just $ T.unwords $ map T.pack
+		[ "git-annex"
+		, show pairstage
+		, fromUUID u
 		]
-		[]
+	}
 
-isPairingNotification :: Presence -> Maybe (PairStage, UUID)
+decodePairingNotification :: IQ -> Maybe NetMessage
-isPairingNotification p = case filter isGitAnnexTag (presencePayloads p) of
+decodePairingNotification iq = parseid =<< words . T.unpack <$> iqID iq
-	[] -> Nothing
+  where
-	((Element _name attrs _nodes):_) ->
+	parseid ["git-annex", stage, u] = 
-		(,)
+		PairingNotification
-			<$> (readish =<< getAttr pairingAttr attrs)
+			<$> readish stage
-			<*> (toUUID <$> getAttr uuidAttr attrs)
+			<*> (formatJID <$> iqFrom iq)
+			<*> pure (toUUID u)
+	parseid _ = Nothing

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

templates/configurators/pairing/xmpp/inprogress.hamlet

@@ -0,0 +1,16 @@
+<div .span9 .hero-unit>
+  <h2>
+    Pairing in progress ..
+    $if samejid
+      <p>
+        A pair request has been sent to all other clients using your jabber #
+        account, #{account}.
+      <p>
+        You do not need to leave this page open; pairing will finish #
+        automatically once the other clients see the pair request.
+    $else
+      <p>
+        A pair request has been sent to #{name}.
+      <p>
+        You do not need to leave this page open; pairing will finish #
+        automatically once #{name} accepts the pair request.