XMPP pair requests are now received, and an alert displayed

Assistant.hs

@@ -136,15 +136,15 @@ import Assistant.Threads.NetWatcher
 import Assistant.Threads.TransferScanner
 import Assistant.Threads.TransferPoller
 import Assistant.Threads.ConfigMonitor
-#ifdef WITH_XMPP
-import Assistant.Threads.XMPPClient
-#endif
 #ifdef WITH_WEBAPP
 import Assistant.WebApp
 import Assistant.Threads.WebApp
 #ifdef WITH_PAIRING
 import Assistant.Threads.PairListener
 #endif
+#ifdef WITH_XMPP
+import Assistant.Threads.XMPPClient
+#endif
 #else
 #warning Building without the webapp. You probably need to install Yesod..
 #endif
@@ -191,6 +191,9 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 #ifdef WITH_PAIRING
 			, assist $ pairListenerThread urlrenderer
 #endif
+#ifdef WITH_XMPP
+			, assist $ xmppClientThread urlrenderer
+#endif
 #endif
 			, assist $ pushThread
 			, assist $ pushRetryThread
@@ -205,9 +208,6 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 			, assist $ netWatcherFallbackThread
 			, assist $ transferScannerThread
 			, assist $ configMonitorThread
-#ifdef WITH_XMPP
-			, assist $ xmppClientThread
-#endif
 			, watch $ watchThread
 			]
 		liftIO waitForTermination

Assistant/Alert.hs

@@ -301,23 +301,23 @@ pairingAlert button = baseActivityAlert
 	}
 
 pairRequestReceivedAlert :: String -> AlertButton -> Alert
-pairRequestReceivedAlert repo button = Alert
+pairRequestReceivedAlert who button = Alert
 	{ alertClass = Message
 	, alertHeader = Nothing
 	, alertMessageRender = tenseWords
-	, alertData = [UnTensed $ T.pack $ repo ++ " is sending a pair request."]
+	, alertData = [UnTensed $ T.pack $ who ++ " is sending a pair request."]
 	, alertBlockDisplay = False
 	, alertPriority = High
 	, alertClosable = True
 	, alertIcon = Just InfoIcon
-	, alertName = Just $ PairAlert repo
+	, alertName = Just $ PairAlert who
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertButton = Just button
 	}
 
 pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
-pairRequestAcknowledgedAlert repo button = baseActivityAlert
+pairRequestAcknowledgedAlert who button = baseActivityAlert
-	{ alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"]
+	{ alertData = ["Pair request with", UnTensed (T.pack who), Tensed "in progress" "complete"]
 	, alertPriority = High
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertButton = button

Assistant/Threads/XMPPClient.hs

@@ -18,27 +18,35 @@ import Assistant.Sync
 import Assistant.DaemonStatus
 import qualified Remote
 import Utility.ThreadScheduler
+import Assistant.WebApp
+import Assistant.WebApp.Types
+import Assistant.Alert
+import Assistant.Pairing
 
 import Network.Protocol.XMPP
 import Control.Concurrent
+import qualified Data.Text as T
 import qualified Data.Set as S
 import qualified Git.Branch
 import Data.Time.Clock
 
-xmppClientThread :: NamedThread
+xmppClientThread :: UrlRenderer -> NamedThread
-xmppClientThread = NamedThread "XMPPClient" $ do
+xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
+	{- All Assistant actions have to be converted into IO actions that
+	 - can be run from within the XMPP monad using liftIO. Ugly. -}
 	iodebug <- asIO1 debug
 	iopull <- asIO1 pull
+	iopairReqReceived <- asIO2 $ pairReqReceived urlrenderer
 	ioupdatebuddies <- asIO1 $ \p ->
 		updateBuddyList (updateBuddies p) <<~ buddyList
 	ioemptybuddies <- asIO $
 		updateBuddyList (const noBuddies) <<~ buddyList
 	iorelay <- asIO1 relayNetMessage
 	ioclientthread <- asIO $
-		go iorelay iodebug iopull ioupdatebuddies ioemptybuddies
+		go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived
 	restartableClient ioclientthread
   where
-	go iorelay iodebug iopull ioupdatebuddies ioemptybuddies = do
+	go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived = do
 		v <- liftAnnex getXMPPCreds
 		case v of
 			Nothing -> noop
@@ -75,10 +83,9 @@ xmppClientThread = NamedThread "XMPPClient" $ do
 				a
 
 		receivenotifications fulljid = forever $ do
-			s <- getStanza
+			l <- decodeStanza fulljid <$> getStanza
-			let vs = decodeStanza fulljid s
+			debug' ["received:", show l]
-			debug' ["received:", show vs]
+			mapM_ handle l
-			mapM_ handle vs
 
 		handle (PresenceMessage p) =
 			void $ liftIO $ ioupdatebuddies p
@@ -86,22 +93,28 @@ xmppClientThread = NamedThread "XMPPClient" $ do
 			putStanza $ gitAnnexPresence gitAnnexSignature
 		handle (GotNetMessage (NotifyPush us)) =
 			void $ liftIO $ iopull us
-		handle (GotNetMessage (PairingNotification stage t u)) = case parseJID t of
+		handle (GotNetMessage (PairingNotification stage t u)) =
-			Nothing -> noop
+			maybe noop (handlePairing stage u) (parseJID t)
-			Just jid -> error "TODO"
 		handle (Ignorable _) = noop
 		handle (Unknown _) = noop
+		handle (ProtocolError _) = noop
+
+		handlePairing PairReq u jid = liftIO $ iopairReqReceived u jid
+		handlePairing PairAck _ _ = error "TODO"
+		handlePairing PairDone _ _ = error "TODO"
 
 data XMPPEvent
 	= GotNetMessage NetMessage
 	| PresenceMessage Presence
 	| Ignorable Presence
 	| Unknown ReceivedStanza
+	| ProtocolError ReceivedStanza
 	deriving Show
 
 {- Decodes an XMPP stanza into one or more events. -}
 decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
-decodeStanza fulljid (ReceivedPresence p)
+decodeStanza fulljid s@(ReceivedPresence p)
+	| presenceType p == PresenceError = [ProtocolError s]
 	| presenceFrom p == Nothing = [Ignorable p]
 	| presenceFrom p == Just fulljid = [Ignorable p]
 	| not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed
@@ -113,9 +126,11 @@ decodeStanza fulljid (ReceivedPresence p)
 	impliedp v = [PresenceMessage p, v]
 	pushed = concat $ catMaybes $ map decodePushNotification $
 		presencePayloads p
-decodeStanza _ s@(ReceivedIQ iq) = case decodePairingNotification iq of
+decodeStanza _ s@(ReceivedIQ iq)
-	Nothing -> [Unknown s]
+	| iqType iq == IQError = [ProtocolError s]
-	Just pn -> [GotNetMessage pn]
+	| otherwise = 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. -}
@@ -126,7 +141,9 @@ relayNetMessage fulljid = convert <$> waitNetMessage
 	convert QueryPresence = putStanza $ presenceQuery
 	convert (PairingNotification stage t u) = case parseJID t of
 		Nothing -> noop
-		Just tojid -> putStanza $ pairingNotification stage u tojid fulljid
+		Just tojid -> do
+			liftIO $ print $ pairingNotification stage u tojid fulljid
+			putStanza $ pairingNotification stage u tojid fulljid
 
 {- Runs the client, handing restart events. -}
 restartableClient :: IO () -> Assistant ()
@@ -170,3 +187,18 @@ pull us = do
 	pullone (r:rs) branch =
 		unlessM (all id . fst <$> manualPull branch [r]) $
 			pullone rs branch
+
+{- Show an alert when a PairReq is seen, unless the PairReq came from
+ - another client using our JID. In that case, just start pairing. -}
+pairReqReceived :: UrlRenderer -> UUID -> JID -> Assistant ()
+pairReqReceived urlrenderer u jid = do
+	-- TODO: check same JID
+	let route = FinishXMPPPairR (PairKey u $ formatJID jid)
+	url <- liftIO $ renderUrl urlrenderer route []
+	close <- asIO1 removeAlert
+	void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName jid)
+		AlertButton
+			{ buttonUrl = url
+			, buttonLabel = T.pack "Respond"
+			, buttonAction = Just close
+			}

Assistant/Types/Buddies.hs

@@ -38,11 +38,11 @@ data Buddy
 #endif
 	deriving (Eq, Show)
 
-data BuddyID = BuddyID T.Text
+data BuddyKey = BuddyKey T.Text
 	deriving (Eq, Ord, Show, Read)
 
-data BuddyKey = BuddyKey T.Text
+data PairKey = PairKey UUID T.Text
-	deriving (Eq, Ord, Show)
+	deriving (Eq, Ord, Show, Read)
 
 type Buddies = M.Map BuddyKey Buddy
 
@@ -60,6 +60,9 @@ newBuddyList = (,)
 getBuddyList :: BuddyList -> IO [Buddy]
 getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)
 
+getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy)
+getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v)
+
 getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster
 getBuddyBroadcaster (_, h) = h
 

Assistant/WebApp/Configurators/Pairing.hs

@@ -47,6 +47,9 @@ import Data.Char
 import qualified Control.Exception as E
 import Control.Concurrent
 #endif
+#ifdef WITH_XMPP
+import qualified Data.Set as S
+#endif
 
 {- Starts either kind of pairing. -}
 getStartPairR :: Handler RepHtml
@@ -73,26 +76,35 @@ getStartPairR = noPairing "local or jabber"
 
 {- Starts pairing with an XMPP buddy, or with other clients sharing an
  - XMPP account. -}
-getStartXMPPPairR :: BuddyID -> Handler RepHtml
+getStartXMPPPairR :: BuddyKey -> Handler RepHtml
 #ifdef WITH_XMPP
-getStartXMPPPairR (BuddyID bid) = case parseJID bid of
+getStartXMPPPairR bid = do
-	Nothing -> error "bad JID"
+	creds <- runAnnex Nothing getXMPPCreds
-	Just jid -> do
+	let ourjid = fromJust $ parseJID =<< xmppJID <$> creds
-		creds <- runAnnex Nothing getXMPPCreds
+	buddy <- liftAssistant $ getBuddy bid <<~ buddyList
-		let ourjid = fromJust $ parseJID =<< xmppJID <$> creds
+	case S.toList . buddyAssistants <$> buddy of
-		liftAssistant $ do
+		-- A buddy could have logged out, or the XMPP client restarted;
-			u <- liftAnnex getUUID
+		-- so handle unforseen by going back.
-			sendNetMessage $ PairingNotification
+		Nothing -> redirect StartPairR
-				PairReq (formatJID jid) u
+		(Just []) -> redirect StartPairR
-		pairPage $ do
+		(Just clients@((Client exemplar):_)) -> do
-			let samejid = equivjids jid ourjid
+			let samejid = basejid ourjid == basejid exemplar
-			let account = formatJID jid
+			liftAssistant $ forM_ clients $ \(Client jid) ->
-			let name = buddyName jid
+				unless (jid == ourjid) $ do
-			$(widgetFile "configurators/pairing/xmpp/inprogress")
+					u <- liftAnnex getUUID
+					sendNetMessage $ PairingNotification
+						PairReq (formatJID jid) u
+			pairPage $ do
+				let account = formatJID $ basejid exemplar
+				let name = buddyName exemplar
+				$(widgetFile "configurators/pairing/xmpp/inprogress")
   where
-	equivjids a b = jidNode a == jidNode b && jidDomain a == jidDomain b
+	basejid j = JID (jidNode j) (jidDomain j) Nothing
 #else
-getStartXMPPPairR _ = noPairing "XMPP"
+getStartXMPPPairR _ = noXMPPPairing
+
+noXMPPPairing :: Handler RepHtml
+noXMPPPairing = noPairing "XMPP"
 #endif
 
 {- Starts local pairing. -}
@@ -125,6 +137,15 @@ getFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
 getFinishLocalPairR _ = noLocalPairing
 #endif
 
+getFinishXMPPPairR :: PairKey -> Handler RepHtml
+#ifdef WITH_XMPP
+getFinishXMPPPairR (PairKey u t) = case parseJID t of
+	Nothing -> error "bad JID"
+	Just jid -> error "TODO"
+#else
+getFinishXMPPPairR _ _ = noXMPPPairing
+#endif
+
 getRunningLocalPairR :: SecretReminder -> Handler RepHtml
 #ifdef WITH_PAIRING
 getRunningLocalPairR s = pairPage $ do

Assistant/WebApp/Types.hs

@@ -90,6 +90,10 @@ instance PathPiece UUID where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
 
-instance PathPiece BuddyID where
+instance PathPiece BuddyKey where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+instance PathPiece PairKey where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -30,7 +30,8 @@
 /config/repository/pair/local/start StartLocalPairR GET
 /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
 /config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET
-/config/repository/pair/xmpp/start/#BuddyID StartXMPPPairR GET
+/config/repository/pair/xmpp/start/#BuddyKey StartXMPPPairR GET
+/config/repository/pair/xmpp/finish/#PairKey FinishXMPPPairR GET
 
 /config/repository/enable/rsync/#UUID EnableRsyncR GET
 /config/repository/enable/directory/#UUID EnableDirectoryR GET

Assistant/XMPP.hs

@@ -86,24 +86,28 @@ isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
 	((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs
 
 {- A notification about a stage of pairing. Sent as an XMPP ping. 
- - The pairing info is sent using its id attribute. -}
+ - The pairing info is sent using its id attribute; it also has a git-annex
+ - tag to identify it as from us. -}
 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
-		, show pairstage
 		, fromUUID u
 		]
+	, iqPayload = Just gitAnnexSignature
 	}
 
 decodePairingNotification :: IQ -> Maybe NetMessage
-decodePairingNotification iq = parseid =<< words . T.unpack <$> iqID iq
+decodePairingNotification iq@(IQ { iqPayload = Just elt })
+	| isGitAnnexTag elt = parseid =<< words . T.unpack <$> iqID iq
+	| otherwise = Nothing
   where
-	parseid ["git-annex", stage, u] = 
+	parseid [stage, u] = 
 		PairingNotification
 			<$> readish stage
 			<*> (formatJID <$> iqFrom iq)
 			<*> pure (toUUID u)
 	parseid _ = Nothing
+decodePairingNotification _ = Nothing

Assistant/XMPP/Buddies.hs

@@ -17,9 +17,6 @@ import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 
-genBuddyID :: JID -> BuddyID
-genBuddyID j = BuddyID $ formatJID j
-
 genKey :: JID -> BuddyKey
 genKey j = BuddyKey $ formatJID $ JID (jidNode j) (jidDomain j) Nothing
 
@@ -29,9 +26,9 @@ 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 :: Buddy -> Maybe (Text, Bool, Bool, BuddyKey)
 buddySummary b = case clients of
-	((Client j):_) -> Just (buddyName j, away, canpair, genBuddyID j)
+	((Client j):_) -> Just (buddyName j, away, canpair, genKey j)
 	[] -> Nothing
   where
 	away = S.null (buddyPresent b) && S.null (buddyAssistants b)

templates/configurators/pairing/xmpp/inprogress.hamlet

@@ -14,3 +14,6 @@
       <p>
         You do not need to leave this page open; pairing will finish #
         automatically once #{name} accepts the pair request.
+    <p>
+      <a .btn .btn-primary .btn-small href="">
+        Re-Send pair request