1 files changed, 39 insertions, 3 deletions

diff --git a/Presence/main.hs b/Presence/main.hs
index bf4809a8..a7ff5e5a 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE ExistentialQuantification #-}
 module Main where
 
 import System.Directory
@@ -79,6 +80,7 @@ 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
+    , rosterChannel :: TMVar (RefCount,TChan RosterEvent)
     , remoteUsers :: TVar (Map Peer (RefCount,TVar (MultiMap JabberUser (JabberResource,JabberShow))))
     , outGoingConnections :: TVar (Map Peer (TChan OutBoundMessage, ThreadId)) 
     }
@@ -99,6 +101,7 @@ data ClientSession = ClientSession {
     localhost :: Peer, -- ByteString,
     unix_uid :: (IORef (Maybe (UserID,L.ByteString))),
     unix_resource :: (IORef (Maybe L.ByteString)),
+    chans :: TVar [RefCountedChan],
     presence_state :: PresenceState
 }
 
@@ -112,7 +115,8 @@ instance JabberClientSession ClientSession where
         L.putStrLn $ "CLIENT SESSION: open " <++> bshow muid
         uid_ref <- newIORef muid
         res_ref <- newIORef Nothing
-        return $ ClientSession (hostname state) uid_ref res_ref state
+        chans <- atomically $ newTVar []
+        return $ ClientSession (hostname state) uid_ref res_ref chans state
 
     setResource  s  resource    = do
         -- TODO: handle resource = empty string 
@@ -137,15 +141,30 @@ instance JabberClientSession ClientSession where
         return (JID (Just user) host rsc)
 
     closeSession session  = do
+        atomically $ do
+            cs <- readTVar (chans session)
+            forM_ cs $ \(RefCountedChan c) -> do
+                unsubscribeToChan c
         L.putStrLn "CLIENT SESSION: close"
 
     subscribe session Nothing = do
         let tmvar = localSubscriber (presence_state session)
-        atomically $ subscribeToChan tmvar
+        atomically $ do
+            cs <- readTVar (chans session)
+            writeTVar (chans session) (RefCountedChan tmvar:cs)
+            subscribeToChan tmvar
     subscribe session (Just jid) = do -- UNUSED as yet
         let tvar = subscriberMap (presence_state session)
         atomically $ subscribeToMap tvar jid
 
+    subscribeToRoster session = do
+        let rchan = rosterChannel . presence_state $ session
+        atomically $ do
+            cs <- readTVar (chans session)
+            writeTVar (chans session) (RefCountedChan rchan:cs)
+            subscribeToChan rchan
+            
+
     forCachedPresence s action = do
         jid <- getJID s 
         L.putStrLn $ "forCachedPresence "<++> bshow jid
@@ -171,6 +190,13 @@ instance JabberClientSession ClientSession where
     addSolicited s jid = do
         user <- readIORef (unix_uid s) >>= getJabberUserForId
         ConfigFiles.addSolicited user jid -- (L.show jid)
+        let rchan = rosterChannel . presence_state $ s
+        atomically $ do
+            isempty <- isEmptyTMVar rchan
+            when (not isempty) $ do
+            (_,ch) <- readTMVar rchan
+            writeTChan ch (RequestedSubscription user jid)
+            
 
     getMyBuddies s = do
         user <- readIORef (unix_uid s) >>= getJabberUserForId
@@ -251,6 +277,9 @@ instance JabberPeerSession PeerSession where
     getSubscribers _ user = ConfigFiles.getSubscribers user
 
 
+data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a))
+
+subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a)
 subscribeToChan tmvar =
             (do (cnt,chan) <- takeTMVar tmvar
                 putTMVar tmvar (cnt+1,chan)
@@ -260,6 +289,12 @@ subscribeToChan tmvar =
             (do chan <- newTChan
                 putTMVar tmvar (1,chan)
                 return chan )
+unsubscribeToChan :: TMVar (RefCount,TChan a) -> STM ()
+unsubscribeToChan tmvar = do
+    isEmpty <- isEmptyTMVar tmvar
+    when (not isEmpty) $ do
+    (cnt,chan) <- takeTMVar tmvar
+    when (cnt>1) (putTMVar tmvar (cnt-1,chan))
 
 getRefFromMap tvar key newObject copyObject = do
     subs <- readTVar tvar
@@ -322,9 +357,10 @@ newPresenceState hostname = atomically $ do
     us   <- newTVar (Set.empty)
     subs <- newTVar (Map.empty)
     locals_greedy <- newEmptyTMVar
+    rchan <- newEmptyTMVar
     remotes <- newTVar (Map.empty)
     server_connections <- newServerConnections
-    return $ PresenceState hostname tty us subs locals_greedy remotes server_connections
+    return $ PresenceState hostname tty us subs locals_greedy rchan remotes server_connections
 
 sendProbes state jid = do
     L.putStrLn $ "sending probes for " <++> bshow jid