summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Assistant/Threads/PairListener.hs2
-rw-r--r--Assistant/Types/Buddies.hs39
-rw-r--r--Assistant/XMPP/Buddies.hs38
-rw-r--r--doc/assistant/buddylist.pngbin0 -> 4347 bytes
4 files changed, 49 insertions, 30 deletions
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 90fce8777..cd297fad3 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -103,7 +103,7 @@ pairListenerThread urlrenderer = NamedThread "PairListener" $ do
pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
pairReqReceived True _ _ = noop -- ignore our own PairReq
pairReqReceived False urlrenderer msg = do
- url <- liftIO $ renderUrl urlrenderer (FinishPairR msg) []
+ url <- liftIO $ renderUrl urlrenderer (FinishLocalPairR msg) []
close <- asIO1 removeAlert
void $ addAlert $ pairRequestReceivedAlert repo
AlertButton
diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs
index 06ac5526d..9c070aa6a 100644
--- a/Assistant/Types/Buddies.hs
+++ b/Assistant/Types/Buddies.hs
@@ -14,16 +14,37 @@ import Common.Annex
import qualified Data.Map as M
import Control.Concurrent.STM
import Utility.NotificationBroadcaster
+import Data.Text as T
-{- When XMPP is enabled, this is an XMPP buddy map.
- - Otherwise, it's an empty map, for simplicity. -}
+{- For simplicity, dummy types are defined even when XMPP is disabled. -}
#ifdef WITH_XMPP
-import Assistant.XMPP.Buddies
+import Network.Protocol.XMPP
+import Data.Set as S
+import Data.Ord
+
+newtype Client = Client JID
+ deriving (Eq, Show)
+
+instance Ord Client where
+ compare = comparing show
+
+data Buddy = Buddy
+ { buddyPresent :: S.Set Client
+ , buddyAway :: S.Set Client
+ , buddyAssistants :: S.Set Client
+ }
#else
-type Buddies = M.Map String Buddy
data Buddy
- deriving (Eq)
#endif
+ deriving (Eq, Show)
+
+data BuddyID = BuddyID T.Text
+ deriving (Eq, Ord, Show, Read)
+
+data BuddyKey = BuddyKey T.Text
+ deriving (Eq, Ord, Show)
+
+type Buddies = M.Map BuddyKey Buddy
{- A list of buddies, and a way to notify when it changes. -}
type BuddyList = (TMVar Buddies, NotificationBroadcaster)
@@ -39,6 +60,9 @@ newBuddyList = (,)
getBuddyList :: BuddyList -> IO [Buddy]
getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)
+getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster
+getBuddyBroadcaster (_, h) = h
+
{- Applies a function to modify the buddy list, and if it's changed,
- sends notifications to any listeners. -}
updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO ()
@@ -50,8 +74,3 @@ updateBuddyList a (v, caster) = do
return $ buds /= buds'
when changed $
sendNotification caster
-
-{- Allocates a notification handle for a client to use to listen for
- - changes to the buddy list. -}
-newBuddyListNotificationHandle :: BuddyList -> IO NotificationHandle
-newBuddyListNotificationHandle (_, caster) = newNotificationHandle caster
diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs
index de2b570c6..db56235c7 100644
--- a/Assistant/XMPP/Buddies.hs
+++ b/Assistant/XMPP/Buddies.hs
@@ -9,32 +9,32 @@ module Assistant.XMPP.Buddies where
import Assistant.XMPP
import Common.Annex
+import Assistant.Types.Buddies
import Network.Protocol.XMPP
import qualified Data.Map as M
import qualified Data.Set as S
-import Data.Ord
+import Data.Text (Text)
+import qualified Data.Text as T
-newtype Client = Client JID
- deriving (Eq, Show)
+genBuddyID :: JID -> BuddyID
+genBuddyID j = BuddyID $ formatJID j
-instance Ord Client where
- compare = comparing show
+genKey :: JID -> BuddyKey
+genKey j = BuddyKey $ formatJID $ JID (jidNode j) (jidDomain j) Nothing
-data Buddy = Buddy
- { buddyPresent :: S.Set Client
- , buddyAway :: S.Set Client
- , buddyAssistants :: S.Set Client
- }
- deriving (Eq, Show)
-
-{- Note that the buddy map includes one buddy for the user's own JID,
- - so that we can track other git-annex assistant's sharing the same
- - account. -}
-type Buddies = M.Map String Buddy
-
-genKey :: JID -> String
-genKey j = show $ JID (jidNode j) (jidDomain j) Nothing
+{- 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)
+ [] -> 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
{- Updates the buddies with XMPP presence info. -}
updateBuddies :: Presence -> Buddies -> Buddies
diff --git a/doc/assistant/buddylist.png b/doc/assistant/buddylist.png
new file mode 100644
index 000000000..40b5a9238
--- /dev/null
+++ b/doc/assistant/buddylist.png
Binary files differ