show when a buddy is already paired

Assistant/NetMessager.hs

@@ -9,12 +9,15 @@ module Assistant.NetMessager where
 
 import Assistant.Common
 import Assistant.Types.NetMessager
+import qualified Types.Remote as Remote
+import qualified Git
 
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
 import Control.Exception as E
 import qualified Data.Set as S
+import qualified Data.Text as T
 
 sendNetMessage :: NetMessage -> Assistant ()
 sendNetMessage m = 
@@ -93,3 +96,12 @@ queueNetPushMessage m = do
 
 waitNetPushMessage :: Assistant (NetMessage)
 waitNetPushMessage = (atomically . readTChan) <<~ (netMessagesPush . netMessager)
+
+{- Remotes using the XMPP transport have urls like xmpp::user@host -}
+isXMPPRemote :: Remote -> Bool
+isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
+  where
+	r = Remote.repo remote
+
+getXMPPClientID :: Remote -> ClientID
+getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))

Assistant/Sync.hs

@@ -27,7 +27,6 @@ import Annex.UUID
 
 import Data.Time.Clock
 import qualified Data.Map as M
-import qualified Data.Text as T
 import Control.Concurrent
 
 {- Syncs with remotes that may have been disconnected for a while.
@@ -176,12 +175,3 @@ syncNewRemote remote = do
 	thread <- asIO $ do
 		reconnectRemotes False [remote]
 	void $ liftIO $ forkIO $ thread
-
-{- Remotes using the XMPP transport have urls like xmpp::user@host -}
-isXMPPRemote :: Remote -> Bool
-isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
-  where
-	r = Remote.repo remote
-
-getXMPPClientID :: Remote -> ClientID
-getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))

Assistant/WebApp/Configurators/XMPP.hs

@@ -99,7 +99,10 @@ buddyListDisplay :: Widget
 buddyListDisplay = do
 	autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
 #ifdef WITH_XMPP
-	buddies <- lift $ liftAssistant $ catMaybes . map buddySummary
+	buddies <- lift $ liftAssistant $ do
+		rs <- filter isXMPPRemote . syncRemotes <$> getDaemonStatus
+		let pairedwith = catMaybes $ map (parseJID . getXMPPClientID) rs
+		catMaybes . map (buddySummary pairedwith)
 			<$> (getBuddyList <<~ buddyList)
 #else
 	let buddies = []

Assistant/XMPP/Buddies.hs

@@ -26,14 +26,15 @@ 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, BuddyKey)
-buddySummary b = case clients of
-	((Client j):_) -> Just (buddyName j, away, canpair, genBuddyKey j)
+buddySummary :: [JID] -> Buddy -> Maybe (Text, Bool, Bool, Bool, BuddyKey)
+buddySummary pairedwith b = case clients of
+	((Client j):_) -> Just (buddyName j, away, canpair, alreadypaired j, genBuddyKey j)
 	[] -> Nothing
   where
 	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
+	alreadypaired j = baseJID j `elem` pairedwith
 
 {- Updates the buddies with XMPP presence info. -}
 updateBuddies :: Presence -> Buddies -> Buddies

templates/configurators/xmpp/buddylist.hamlet

@@ -6,7 +6,7 @@
         <td> 
           Nobody is currently available.
     $else
-      $forall (name, away, canpair, buddyid) <- buddies
+      $forall (name, away, canpair, paired, buddyid) <- buddies
         <tr>
           <td>
             <i .icon-user></i> #
@@ -19,6 +19,10 @@
             $if away
               <span .muted>
                 away
+            $else
+              $if paired
+                <span .label .label-success>
+                  paired
               $else
                 $if canpair
                   <a .btn .btn-primary .btn-small href="@{StartXMPPPairR buddyid}">