From 563125c8dc8c73b6382708637a12c72110cd0662 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 11 Jul 2013 15:57:30 -0400 Subject: roster updates and presence notification in case of a new subscription. --- Presence/XMPP.hs | 27 +++++++++++++++++++++---- Presence/XMPPTypes.hs | 6 +++++- Presence/main.hs | 56 +++++++++++++++++++++++++++++++++++++-------------- 3 files changed, 69 insertions(+), 20 deletions(-) diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index 173e7cdf..7d69e126 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -535,7 +535,7 @@ toClient session pchan cmdChan rchan = toClient' False False , attr "type" "subscribed" ] , EventEndElement "{jabber:client}presence" ] - let f True = "from" + let f True = "both" f False = "to" subscription <- fmap f (liftIO $ isSubscribed session contact) r <- liftIO . handleIO (\e -> putStrLn ("Roster NewBuddy error: "++show e) >> return []) $ do @@ -544,7 +544,24 @@ toClient session pchan cmdChan rchan = toClient' False False [attr "subscription" subscription] send r loop - RChan (PendingBuddy who contact) -> do + RChan (NewSubscriber who contact) -> do + liftIO . putStrLn $ "Roster push: NewSubscriber "++show (isInterested,who,contact) + (jid,me) <- liftIO $ do + jid <- getJID session + me <- asHostNameJID jid + return (jid,me) + withJust me $ \me -> do + when (isInterested && Just who==name jid) $ do + let f True = "both" + f False = "from" + subscription <- fmap f (liftIO $ isBuddy session contact) + r <- liftIO . handleIO (\e -> putStrLn ("Roster NewSubscriber error: "++show e) >> return []) $ do + rosterPush jid + (toStrict . L.decodeUtf8 $ contact) + [attr "subscription" subscription] + send r + loop + RChan (PendingSubscriber who contact) -> do liftIO . putStrLn $ "Roster: Pending buddy "++show (isInterested,who,contact) (jid,me) <- liftIO $ do jid <- getJID session @@ -726,7 +743,8 @@ handlePresenceProbe session stanza = do putStrLn $ "comparing " ++show (peer sub , peerAddress session) when (peer sub == discardPort (peerAddress session)) $ do ps <- userStatus session user - mapM_ (announcePresence session) ps + -- todo: Consider making this a directed presence + mapM_ (sendPeerMessage session . OutBoundPresence) ps return () subscribeToPresence subscribers peer_jid user = do @@ -826,7 +844,8 @@ peerRequestsSubsription session stanza = do liftIO $ do sendPeerMessage session (Approval tojid fromjid) ps <- userStatus session user - mapM_ (announcePresence session) ps + -- todo: consider making this a directed presence + mapM_ (sendPeerMessage session . OutBoundPresence) ps else liftIO $ processRequest session user fromjid diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs index 6d00d509..0e98a77b 100644 --- a/Presence/XMPPTypes.hs +++ b/Presence/XMPPTypes.hs @@ -57,6 +57,7 @@ class JabberClientSession session where getMySolicited :: session -> IO [ByteString] addSolicited :: session -> ByteString -> JID -> IO () isSubscribed :: session -> ByteString -> IO Bool + isBuddy :: session -> ByteString -> IO Bool approveSubscriber :: session -> ByteString -> IO () class JabberPeerSession session where @@ -94,7 +95,10 @@ data RosterEvent = RequestedSubscription | NewBuddy {- user: -} ByteString {- contact: -} ByteString - | PendingBuddy + | PendingSubscriber + {- user: -} ByteString + {- contact: -} ByteString + | NewSubscriber {- user: -} ByteString {- contact: -} ByteString deriving Prelude.Show diff --git a/Presence/main.hs b/Presence/main.hs index 5cccffea..702b98d5 100644 --- a/Presence/main.hs +++ b/Presence/main.hs @@ -222,7 +222,7 @@ instance JabberClientSession ClientSession where else return Nothing atomically $ do whenJust getRChan $ \rchan -> do - forM_ pending (writeTChan rchan . PendingBuddy user) + forM_ pending (writeTChan rchan . PendingSubscriber user) addSolicited s jid_str jid = do me <- getJID s @@ -264,6 +264,16 @@ instance JabberClientSession ClientSession where msubs <- mapM (cmpJID cjid) subs return (Nothing `elem` msubs) + isBuddy s contact = do + handleIO (\e -> return False) $ do + user <- readIORef (unix_uid s) >>= getJabberUserForId + subs <- ConfigFiles.getBuddies user + putStrLn $ "isBuddy parsing: "<++>contact + cjid <- parseHostNameJID contact + msubs <- mapM (cmpJID cjid) subs + return (Nothing `elem` msubs) + + approveSubscriber s contact = do user <- readIORef (unix_uid s) >>= getJabberUserForId cjid <- parseHostNameJID contact @@ -271,16 +281,40 @@ instance JabberClientSession ClientSession where addRawJid ConfigFiles.modifySubscribers user contact -- add subscribers rmjid ConfigFiles.modifyPending user cjid rmjid ConfigFiles.modifyOthers user cjid - -- TODO - -- roster push (to other clients, or do we include the approver?) + + -- roster push + let rchan = rosterChannel . presence_state $ s + atomically $ do + isempty <- isEmptyTMVar rchan + when (not isempty) $ do + (_,ch) <- readTMVar rchan + writeTChan ch (NewSubscriber user contact) + + -- notify peer sendMessage (outGoingConnections . presence_state $ s) (Approval (JID (Just user) LocalHost Nothing) cjid) (peer cjid) + presence <- getUserStatus (presence_state s) user + let cons = outGoingConnections . presence_state $ s + forM_ presence $ \p -> sendMessage cons (OutBoundPresence p) (peer cjid) + return () tupleToJID (user,tty,pid) = jid user LocalHost tty +getUserStatus state user = do + (tty,users) <- atomically $ do + tty <- readTVar $ currentTTY state + users <- readTVar $ activeUsers state + return (tty,users) + let jids = Set.filter (\(name,tty,pid) -> name ==user) users + ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid)) . Set.toList $ jids + if null ps + then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline] + else return ps + + data PeerSession = PeerSession { announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)), peer_name :: Peer, @@ -310,18 +344,10 @@ instance JabberPeerSession PeerSession where peerAddress session = peer_name session - userStatus session user = do - let state = peer_global session - (tty,users) <- atomically $ do - tty <- readTVar $ currentTTY state - users <- readTVar $ activeUsers state - return (tty,users) - let jids = Set.filter (\(name,tty,pid) -> name ==user) users - ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid)) . Set.toList $ jids - if null ps - then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline] - else return ps + userStatus session user = getUserStatus (peer_global session) user + -- This should be used on inbound presence to inform clients. + -- For outbound, use sendPeerMessage and OutBoundPresence. announcePresence session (Presence jid status) = do (greedy,subs) <- atomically $ do subs <- readTVar $ subscriberMap (peer_global session) @@ -384,7 +410,7 @@ instance JabberPeerSession PeerSession where isempty <- isEmptyTMVar rchan when (not isempty) $ do (_,ch) <- readTMVar rchan - writeTChan ch (PendingBuddy user buddy) + writeTChan ch (PendingSubscriber user buddy) data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a)) -- cgit v1.2.3