From e57941161715a28543794bdd346110c67f0cf224 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 20 Jul 2013 21:59:22 -0400 Subject: Now honors client's requested status. --- Presence/main.hs | 62 ++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 45 insertions(+), 17 deletions(-) (limited to 'Presence/main.hs') diff --git a/Presence/main.hs b/Presence/main.hs index 5de660b0..d7510f94 100644 --- a/Presence/main.hs +++ b/Presence/main.hs @@ -15,6 +15,7 @@ import Data.Maybe import Data.Char import ConfigFiles import Control.Arrow (second) +import Data.Traversable (sequenceA) import System.INotify #ifndef NOUTMP @@ -35,7 +36,7 @@ import LocalPeerCred import System.Posix.User import Logging import qualified Data.Set as Set -import Data.Set as Set (Set,(\\)) +import Data.Set as Set ((\\)) import qualified Data.Map as Map import Data.Map as Map (Map) @@ -187,15 +188,26 @@ instance JabberClientSession ClientSession where debugL $ "CLIENT SESSION: resource " <++> rsc' <++> " (wanted: "<++>wanted_resource<++>")" setPresence s stat = do - user <- readIORef (unix_uid s) >>= getJabberUserForId withJust (unix_pid s) $ \client_pid -> do whenJust (readIORef (unix_resource s)) $ \tty -> do - let au = activeUsers . presence_state $ s - atomically $ do + user <- readIORef (unix_uid s) >>= getJabberUserForId + greedysubs <- atomically $ do + let au = activeUsers . presence_state $ s us <- readTVar au - withJust (Map.lookup (user,tty) us) $ \(ttypid,cs) -> do - let entry = (ttypid,Map.insert client_pid (Client {clientShow=stat}) cs) - writeTVar au (Map.insert (user,tty) entry us) + sequenceA $ Map.lookup (user,tty) us >>= \(ttypid,cs) -> do + let entry = (ttypid,Map.insert client_pid (Client {clientShow=stat}) cs) + Just $ do + writeTVar au (Map.insert (user,tty) entry us) + subs <- readTVar $ subscriberMap (presence_state s) + greedy <- fmap snd . readTMVar $ localSubscriber (presence_state s) + activetty <- readTVar $ currentTTY (presence_state s) + usermap <- readTVar $ activeUsers (presence_state s) + return (greedy,subs,activetty,usermap) + withJust greedysubs $ \(greedy,subs,active_tty,usermap) -> do + update_presence (Just greedy) + (fmap snd subs) + [JID (Just user) (localhost s) (Just tty)] + (matchResource usermap active_tty) getJID s = do let host = localhost s @@ -206,12 +218,20 @@ instance JabberClientSession ClientSession where -- debugL $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc) return (JID (Just user) host rsc) - closeSession session = do + closeSession s = do atomically $ do - cs <- readTVar (chans session) + cs <- readTVar (chans s) forM_ cs $ \(RefCountedChan c) -> do unsubscribeToChan c debugL "CLIENT SESSION: close" + withJust (unix_pid s) $ \client_pid -> do + whenJust (readIORef (unix_resource s)) $ \tty -> do + user <- readIORef (unix_uid s) >>= getJabberUserForId + atomically $ do + let au = activeUsers . presence_state $ s + us <- readTVar au + let remove = second (Map.delete client_pid) + writeTVar au (Map.adjust remove (user,tty) us) subscribe session Nothing = do let tmvar = localSubscriber (presence_state session) @@ -616,9 +636,15 @@ unrefFromMap tvar key finalizer = do subscribeToMap tvar jid = getRefFromMap tvar jid newTChan dupTChan -matchResource tty jid = maybe Away (avail . (==tty)) $ resource jid +matchResource usermap tty jid = maybe Away (avail . (==tty)) $ resource jid where - avail True = Available + avail True = case ( name jid >>= \u -> Map.lookup (u,tty) usermap ) of + Nothing -> Available + Just (pid,clients) -> + let stats = map (clientShow . snd) . Map.toList $ clients + in if null stats + then Available + else maximum stats avail False = Away matchResource' tty (_,rsc) = avail (rsc==tty) @@ -682,32 +708,34 @@ track_login host state e = do . map (\((u,tty),pid)-> ((u,tty),(pid,Map.empty))) $ new_users0 (Set.fromList->new_users,_) = unzip new_users0 - (tty,known_users,subs,locals_greedy) <- atomically $ do + (tty,active_users,subs,locals_greedy) <- atomically $ do tty <- readTVar $ currentTTY state st <- flip swapTVar new_users' $ activeUsers state xs <- readTVar $ subscriberMap state locals_greedy <- tryReadTMVar $ localSubscriber state - return (tty,Map.keysSet st,fmap snd xs,fmap snd locals_greedy) + return (tty,st,fmap snd xs,fmap snd locals_greedy) + let known_users = Map.keysSet active_users let arrivals = map tupleToJID . Set.toList $ new_users \\ known_users departures = map tupleToJID . Set.toList $ known_users \\ new_users update_presence locals_greedy subs departures $ const Offline - update_presence locals_greedy subs arrivals $ matchResource tty + update_presence locals_greedy subs arrivals $ matchResource active_users tty forM_ arrivals $ sendProbes state on_chvt state vtnum = do let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum) debugL $ "VT switch: " <++> tty - (users,subs,locals_greedy) <- atomically $ do + (active_users,subs,locals_greedy) <- atomically $ do us <- readTVar $ activeUsers state subs <- readTVar $ subscriberMap state writeTVar (currentTTY state) tty locals_greedy <- tryReadTMVar $ localSubscriber state - return (Map.keysSet us,fmap snd subs,fmap snd locals_greedy) + return (us,fmap snd subs,fmap snd locals_greedy) + let users = Map.keysSet active_users update_presence locals_greedy subs (map tupleToJID . Set.toList $ users) - $ matchResource tty + $ matchResource active_users tty -- start -- -- cgit v1.2.3