diff options
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 2 | ||||
| -rw-r--r-- | Assistant/Types/Buddies.hs | 39 | ||||
| -rw-r--r-- | Assistant/XMPP/Buddies.hs | 38 | ||||
| -rw-r--r-- | doc/assistant/buddylist.png | bin | 0 -> 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 Binary files differnew file mode 100644 index 000000000..40b5a9238 --- /dev/null +++ b/doc/assistant/buddylist.png |
