Progress toward respecting client's requeseted presence state.

3 files changed, 40 insertions, 3 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index fb7d4204..756d300a 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -359,6 +359,28 @@ handleIQGet session cmdChan tag = do
         req -> unhandledGet req
     
 
+handleClientPresence session stanza = do
+    -- online (Available or Away)
+    let log  = liftIO . debugL . ("(C) " <++>)
+    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
+    -- cjid <- liftIO $ parseAddressJID (textToByteString jid)
+    let parseChildren stat = do
+            child <- nextElement
+            case child of
+                Just tag | tagName tag=="{jabber:server}show"
+                                      -> fmap toStat (lift content)
+                Just tag | otherwise  -> parseChildren stat
+                Nothing -> return stat
+        toStat "away" = Away
+        toStat "xa"   = ExtendedAway
+        toStat "dnd"  = DoNotDisturb
+        toStat "chat" = Chatty
+
+    stat' <- parseChildren Available
+    liftIO $ setPresence session stat'
+    log $ "requesting presence: "<++>bshow stat'
+    return ()
+
 fromClient :: (MonadThrow m,MonadIO m, JabberClientSession session) => 
     session -> TChan ClientCommands -> Sink XML.Event m ()
 fromClient session cmdChan = doNestingXML $ do
@@ -395,6 +417,8 @@ fromClient session cmdChan = doNestingXML $ do
                                            -> clientApprovesSubscription session stanza
              _ | stanza `isClientPresenceOf` presenceTypeUnsubscribed
                                            -> clientRejectsSubscription session stanza
+             _ | stanza `isClientPresenceOf` presenceTypeOnline
+                                           -> handleClientPresence session stanza
              _ | otherwise                 -> unhandledStanza
 
             awaitCloser stanza_lvl
@@ -672,6 +696,7 @@ isClientPresenceOf (EventBeginElement name attrs) testType
     = True
 isClientPresenceOf _ _ = False
 
+
 handlePresenceProbe session stanza = do
     withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to -> do
     -- withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from -> do
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index e0b83a6c..b654b320 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -55,6 +55,7 @@ class JabberClientSession session where
     data XMPPClass session
     newSession   :: SocketLike sock => XMPPClass session -> sock -> IO session
     setResource  :: session -> ByteString -> IO ()
+    setPresence  :: session -> JabberShow -> IO ()
     getJID       :: session -> IO JID
     closeSession :: session -> IO ()
     subscribe :: session -> Maybe JID -> IO (TChan Presence)
diff --git a/Presence/main.hs b/Presence/main.hs
index f51e6975..5de660b0 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -55,7 +55,7 @@ import Network.Socket (Family(AF_INET,AF_INET6))
 import           Holumbus.Data.MultiMap as MM (MultiMap)
 import qualified Holumbus.Data.MultiMap as MM
 
-data Client = Client
+data Client = Client { clientShow :: JabberShow }
 
 -- see Data.Map.Lazy.fromSet
 fromSet f = Map.fromList . map (\a -> (a,f a)) . Set.toList
@@ -79,7 +79,7 @@ data PresenceState = PresenceState
 
     -- activeUsers - a is a set of triples representing data in /var/run/utmp
     --               it is kept up to date by an inotify watch on that file.
-    , activeUsers   :: TVar (Map (UserName, Tty) (ProcessID, Set Client))
+    , activeUsers   :: TVar (Map (UserName, Tty) (ProcessID, Map ProcessID Client))
 
     -- subscriberMap  - the idea was to allow subscribing to a particular user only.
     --                  When that user becomes present, an announcement would be sent
@@ -186,6 +186,17 @@ instance JabberClientSession ClientSession where
         writeIORef (unix_resource s) (Just rsc')
         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
+            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)
+
     getJID       s             = do
         let host = localhost s
         user <- readIORef (unix_uid s) >>= getJabberUserForId
@@ -668,7 +679,7 @@ track_login host state e = do
               else Nothing
         new_users0 = mapMaybe (toJabberId host) us
         new_users' = Map.fromList 
-                     . map (\((u,tty),pid)-> ((u,tty),(pid,Set.empty)))
+                     . 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