Send cached presence to client

1 files changed, 61 insertions, 18 deletions

diff --git a/Presence/main.hs b/Presence/main.hs
index 7a0ee2b4..6721db86 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -56,9 +56,22 @@ import           Prelude hiding (putStrLn)
 import System.Environment
 import qualified Text.Show.ByteString as L
 import Network.Socket (Family(AF_INET,AF_INET6))
+import           Holumbus.Data.MultiMap as MM (MultiMap)
+import qualified Holumbus.Data.MultiMap as MM
 
 type RefCount = Int
 
+type JabberResource = L.ByteString
+type JabberName = L.ByteString
+data JabberUser = JabberUser JabberName Peer
+  deriving (Eq,Ord,Show)
+
+splitResource :: JID -> Maybe (JabberUser,Maybe JabberResource)
+splitResource (JID Nothing  _ _  ) = Nothing
+splitResource (JID (Just n) p r  ) = Just (JabberUser n p, r)
+
+unsplitResource (JabberUser n p) r = JID (Just n) p r
+
 data PresenceState = PresenceState 
     { hostname :: Peer -- ByteString, TODO: remove this, its always LocalHost now
     , currentTTY    :: TVar ByteString
@@ -66,11 +79,22 @@ data PresenceState = PresenceState
     , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) -- UNUSED as yet
     , localSubscriber :: TMVar (RefCount,TChan Presence) -- TODO: rename this, its not just locals
                                                          -- ... or make a seperate channel for remotes
-    , remoteUsers :: TVar (Map Peer (RefCount,TVar (Set JID)))
+    , remoteUsers :: TVar (Map Peer (RefCount,TVar (MultiMap JabberUser (JabberResource,JabberShow))))
     , outGoingConnections :: TVar (Map Peer (TChan OutBoundMessage, ThreadId)) 
     }
 
 
+getJabberUserForId muid =
+             maybe (return "nobody") 
+                   (\uid -> 
+                        handle (\(SomeException _) -> 
+                                return . L.append "uid." . L.pack . show $ uid)
+                          $ do
+                             user <- fmap userName $ getUserEntryForID uid
+                             return (L.pack user)
+                        )
+                   muid
+
 data ClientSession = ClientSession {
     localhost :: Peer, -- ByteString,
     unix_uid :: (IORef (Maybe UserID)),
@@ -95,15 +119,8 @@ instance JabberClientSession ClientSession where
     getJID       s             = do
         let host = localhost s
         muid <- readIORef (unix_uid s)
-        user <- maybe (return "nobody") 
-                   (\uid -> 
-                        handle (\(SomeException _) -> 
-                                return . L.append "uid." . L.pack . show $ uid)
-                          $ do
-                             user <- fmap userName $ getUserEntryForID uid
-                             return (L.pack user)
-                        )
-                   muid
+        user <- getJabberUserForId muid
+
         rsc <- readIORef (unix_resource s)
         -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc
         L.putStrLn $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc)
@@ -119,9 +136,30 @@ instance JabberClientSession ClientSession where
         let tvar = subscriberMap (presence_state session)
         atomically $ subscribeToMap tvar jid
 
+    forCachedPresence s action = do
+        jid <- getJID s 
+        L.putStrLn $ "forCachedPresence "<++> bshow jid
+        withJust (name jid) $ \user -> do
+        let parseHostNameJID' str = do
+                handle (\(SomeException _) -> return Nothing)
+                       (fmap Just . parseHostNameJID $ str)
+        buddies <- do
+            buddies <- ConfigFiles.getBuddies user
+            fmap catMaybes (mapM parseHostNameJID' buddies)
+        remotes <- readTVarIO . remoteUsers . presence_state $ s
+        forM_ buddies $ \buddy -> do
+            L.putStrLn $ "forCachedPresence buddy = "<++> bshow buddy
+            let mjids = fmap snd $ Map.lookup (peer buddy) remotes
+            jids <- maybe (return MM.empty) readTVarIO mjids
+            L.putStrLn $ "forCachedPresence jids = "<++> bshow jids
+            withJust (splitResource buddy) $ \(buddyU,_) -> do
+            forM_ (Set.toList . MM.lookup buddyU $ jids) $ \(rsc,status) -> do
+            let p = Presence buddy status
+            L.putStrLn $ "cached presence: " <++> bshow p
+            action p
 
 data PeerSession = PeerSession {
-    announced :: TVar (Set JID),
+    announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)),
     peer_name :: Peer,
     peer_global :: PresenceState
 }
@@ -132,7 +170,7 @@ instance JabberPeerSession PeerSession where
         me <- fmap (RemotePeer . withoutPort) (getPeerName sock)
         L.putStrLn $ "PEER SESSION: open "<++>showPeer me
         let remotes = remoteUsers state
-        jids <- atomically $ getRefFromMap remotes me (newTVar Set.empty) return
+        jids <- atomically $ getRefFromMap remotes me (newTVar MM.empty) return
         return $ PeerSession jids me state
 
     closePeerSession session  = do
@@ -140,8 +178,10 @@ instance JabberPeerSession PeerSession where
         let offline jid = Presence jid Offline
         unrefFromMap (remoteUsers . peer_global $ session) (peer_name session)
             $ do
-                js <- fmap Set.toList (readTVarIO . announced $ session)
-                forM_ js $ announcePresence session . offline
+                js <- fmap (MM.toAscList) (readTVarIO . announced $ session)
+                forM_ js $ \(u,rs) -> do
+                forM_ (Set.toList rs) $ \(rsc,_) -> do
+                announcePresence session . offline $ unsplitResource u (Just rsc)
 
     peerSessionFactory session = PeerSessions (peer_global session)
 
@@ -167,10 +207,12 @@ instance JabberPeerSession PeerSession where
         update_presence (Just greedy) (fmap snd subs) (Set.singleton jid) (const status)
         liftIO . atomically $ do
             jids <- readTVar . announced $ session
+            withJust (splitResource jid) $ \(u,rsc) -> do
+            let match (r',_) = (rsc==Nothing || Just r'==rsc)
             writeTVar (announced session) 
                 $ case status of
-                    Offline -> Set.delete jid jids
-                    _       -> Set.insert jid jids
+                    Offline -> MM.deleteElemIf u match jids
+                    stat    -> maybe jids (\r -> MM.insert u (r,stat) jids) rsc
 
     getBuddies     _ user = ConfigFiles.getBuddies user
     getSubscribers _ user = ConfigFiles.getSubscribers user
@@ -259,8 +301,9 @@ sendProbes state jid = do
     remotes <- readTVarIO (remoteUsers state)
     forM_ buddies $ \buddy -> do
         let mjids = fmap snd $ Map.lookup (peer buddy) remotes
-        jids <- maybe (return Set.empty) readTVarIO mjids
-        let noinfo = Set.notMember buddy jids
+        jids <- maybe (return MM.empty) readTVarIO mjids
+        withJust (splitResource buddy) $ \(buddyU,_) -> do
+        let noinfo = not (MM.member buddyU jids)
         when noinfo $ do
         L.putStrLn $ "sendMessage " <++> bshow (PresenceProbe jid buddy)
         sendMessage (outGoingConnections state) (PresenceProbe jid buddy) (peer buddy)