diff options
Diffstat (limited to 'Presence/main.hs')
-rw-r--r-- | Presence/main.hs | 56 |
1 files changed, 41 insertions, 15 deletions
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 | |||
222 | else return Nothing | 222 | else return Nothing |
223 | atomically $ do | 223 | atomically $ do |
224 | whenJust getRChan $ \rchan -> do | 224 | whenJust getRChan $ \rchan -> do |
225 | forM_ pending (writeTChan rchan . PendingBuddy user) | 225 | forM_ pending (writeTChan rchan . PendingSubscriber user) |
226 | 226 | ||
227 | addSolicited s jid_str jid = do | 227 | addSolicited s jid_str jid = do |
228 | me <- getJID s | 228 | me <- getJID s |
@@ -264,6 +264,16 @@ instance JabberClientSession ClientSession where | |||
264 | msubs <- mapM (cmpJID cjid) subs | 264 | msubs <- mapM (cmpJID cjid) subs |
265 | return (Nothing `elem` msubs) | 265 | return (Nothing `elem` msubs) |
266 | 266 | ||
267 | isBuddy s contact = do | ||
268 | handleIO (\e -> return False) $ do | ||
269 | user <- readIORef (unix_uid s) >>= getJabberUserForId | ||
270 | subs <- ConfigFiles.getBuddies user | ||
271 | putStrLn $ "isBuddy parsing: "<++>contact | ||
272 | cjid <- parseHostNameJID contact | ||
273 | msubs <- mapM (cmpJID cjid) subs | ||
274 | return (Nothing `elem` msubs) | ||
275 | |||
276 | |||
267 | approveSubscriber s contact = do | 277 | approveSubscriber s contact = do |
268 | user <- readIORef (unix_uid s) >>= getJabberUserForId | 278 | user <- readIORef (unix_uid s) >>= getJabberUserForId |
269 | cjid <- parseHostNameJID contact | 279 | cjid <- parseHostNameJID contact |
@@ -271,16 +281,40 @@ instance JabberClientSession ClientSession where | |||
271 | addRawJid ConfigFiles.modifySubscribers user contact -- add subscribers | 281 | addRawJid ConfigFiles.modifySubscribers user contact -- add subscribers |
272 | rmjid ConfigFiles.modifyPending user cjid | 282 | rmjid ConfigFiles.modifyPending user cjid |
273 | rmjid ConfigFiles.modifyOthers user cjid | 283 | rmjid ConfigFiles.modifyOthers user cjid |
274 | -- TODO | 284 | |
275 | -- roster push (to other clients, or do we include the approver?) | 285 | -- roster push |
286 | let rchan = rosterChannel . presence_state $ s | ||
287 | atomically $ do | ||
288 | isempty <- isEmptyTMVar rchan | ||
289 | when (not isempty) $ do | ||
290 | (_,ch) <- readTMVar rchan | ||
291 | writeTChan ch (NewSubscriber user contact) | ||
292 | |||
293 | -- notify peer | ||
276 | sendMessage (outGoingConnections . presence_state $ s) | 294 | sendMessage (outGoingConnections . presence_state $ s) |
277 | (Approval (JID (Just user) LocalHost Nothing) | 295 | (Approval (JID (Just user) LocalHost Nothing) |
278 | cjid) | 296 | cjid) |
279 | (peer cjid) | 297 | (peer cjid) |
298 | presence <- getUserStatus (presence_state s) user | ||
299 | let cons = outGoingConnections . presence_state $ s | ||
300 | forM_ presence $ \p -> sendMessage cons (OutBoundPresence p) (peer cjid) | ||
301 | return () | ||
280 | 302 | ||
281 | 303 | ||
282 | tupleToJID (user,tty,pid) = jid user LocalHost tty | 304 | tupleToJID (user,tty,pid) = jid user LocalHost tty |
283 | 305 | ||
306 | getUserStatus state user = do | ||
307 | (tty,users) <- atomically $ do | ||
308 | tty <- readTVar $ currentTTY state | ||
309 | users <- readTVar $ activeUsers state | ||
310 | return (tty,users) | ||
311 | let jids = Set.filter (\(name,tty,pid) -> name ==user) users | ||
312 | ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid)) . Set.toList $ jids | ||
313 | if null ps | ||
314 | then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline] | ||
315 | else return ps | ||
316 | |||
317 | |||
284 | data PeerSession = PeerSession { | 318 | data PeerSession = PeerSession { |
285 | announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)), | 319 | announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)), |
286 | peer_name :: Peer, | 320 | peer_name :: Peer, |
@@ -310,18 +344,10 @@ instance JabberPeerSession PeerSession where | |||
310 | 344 | ||
311 | peerAddress session = peer_name session | 345 | peerAddress session = peer_name session |
312 | 346 | ||
313 | userStatus session user = do | 347 | userStatus session user = getUserStatus (peer_global session) user |
314 | let state = peer_global session | ||
315 | (tty,users) <- atomically $ do | ||
316 | tty <- readTVar $ currentTTY state | ||
317 | users <- readTVar $ activeUsers state | ||
318 | return (tty,users) | ||
319 | let jids = Set.filter (\(name,tty,pid) -> name ==user) users | ||
320 | ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid)) . Set.toList $ jids | ||
321 | if null ps | ||
322 | then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline] | ||
323 | else return ps | ||
324 | 348 | ||
349 | -- This should be used on inbound presence to inform clients. | ||
350 | -- For outbound, use sendPeerMessage and OutBoundPresence. | ||
325 | announcePresence session (Presence jid status) = do | 351 | announcePresence session (Presence jid status) = do |
326 | (greedy,subs) <- atomically $ do | 352 | (greedy,subs) <- atomically $ do |
327 | subs <- readTVar $ subscriberMap (peer_global session) | 353 | subs <- readTVar $ subscriberMap (peer_global session) |
@@ -384,7 +410,7 @@ instance JabberPeerSession PeerSession where | |||
384 | isempty <- isEmptyTMVar rchan | 410 | isempty <- isEmptyTMVar rchan |
385 | when (not isempty) $ do | 411 | when (not isempty) $ do |
386 | (_,ch) <- readTMVar rchan | 412 | (_,ch) <- readTMVar rchan |
387 | writeTChan ch (PendingBuddy user buddy) | 413 | writeTChan ch (PendingSubscriber user buddy) |
388 | 414 | ||
389 | 415 | ||
390 | data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a)) | 416 | data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a)) |