XMPP pair requests are now received, and an alert displayed

6 files changed, 76 insertions, 40 deletions

diff --git a/Assistant.hs b/Assistant.hs
index a58015c37..5cc9f303f 100644
--- a/Assistant.hs
+++ b/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
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index c729e4de4..8d9455e66 100644
--- a/Assistant/Alert.hs
+++ b/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
-	{ alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"]
+pairRequestAcknowledgedAlert who button = baseActivityAlert
+	{ alertData = ["Pair request with", UnTensed (T.pack who), Tensed "in progress" "complete"]
 	, alertPriority = High
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertButton = button
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 6aeabb24b..974cc83a0 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/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 = NamedThread "XMPPClient" $ do
+xmppClientThread :: UrlRenderer -> NamedThread
+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
-			let vs = decodeStanza fulljid s
-			debug' ["received:", show vs]
-			mapM_ handle vs
+			l <- decodeStanza fulljid <$> getStanza
+			debug' ["received:", show l]
+			mapM_ handle l
 
 		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
-			Nothing -> noop
-			Just jid -> error "TODO"
+		handle (GotNetMessage (PairingNotification stage t u)) =
+			maybe noop (handlePairing stage u) (parseJID t)
 		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
-	Nothing -> [Unknown s]
-	Just pn -> [GotNetMessage pn]
+decodeStanza _ s@(ReceivedIQ iq)
+	| iqType iq == IQError = [ProtocolError s]
+	| 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
+			}
diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs
index 9c070aa6a..3e7ecec62 100644
--- a/Assistant/Types/Buddies.hs
+++ b/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
-	deriving (Eq, Ord, Show)
+data PairKey = PairKey UUID T.Text
+	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
 
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 04eea50f6..3aef76b1a 100644
--- a/Assistant/XMPP.hs
+++ b/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
diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs
index d784f316d..087a34879 100644
--- a/Assistant/XMPP/Buddies.hs
+++ b/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)