diff --git a/Assistant/NetMessager.hs b/Assistant/NetMessager.hs index 5a2746cc70..c3bd73c57d 100644 --- a/Assistant/NetMessager.hs +++ b/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)) diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 8815f40c8b..ae2b5ea369 100644 --- a/Assistant/Sync.hs +++ b/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)) diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index e46a91f2a9..c6648b3dee 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -99,8 +99,11 @@ buddyListDisplay :: Widget buddyListDisplay = do autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int) #ifdef WITH_XMPP - buddies <- lift $ liftAssistant $ catMaybes . map buddySummary - <$> (getBuddyList <<~ buddyList) + 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 = [] #endif diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs index fdc307972d..7383c38d9d 100644 --- a/Assistant/XMPP/Buddies.hs +++ b/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 diff --git a/templates/configurators/xmpp/buddylist.hamlet b/templates/configurators/xmpp/buddylist.hamlet index 11b473bc7c..d978eb004a 100644 --- a/templates/configurators/xmpp/buddylist.hamlet +++ b/templates/configurators/xmpp/buddylist.hamlet @@ -6,7 +6,7 @@ Nobody is currently available. $else - $forall (name, away, canpair, buddyid) <- buddies + $forall (name, away, canpair, paired, buddyid) <- buddies # @@ -20,8 +20,12 @@ away $else - $if canpair - - Start pairing + $if paired + + paired $else - not using git-annex + $if canpair + + Start pairing + $else + not using git-annex