Now honors client's requested status.

1 files changed, 45 insertions, 17 deletions

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
 --