2 files changed, 59 insertions, 32 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 044ed9e4..4a859bc9 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -40,6 +40,33 @@ import Network.Socket
 import Data.String
 import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class
+import Control.DeepSeq
+import Control.Concurrent.STM
+
+-- | Jabber ID (JID) datatype
+data JID = JID { name :: Maybe ByteString
+               , server :: ByteString
+               , resource :: Maybe ByteString
+               }
+ deriving (Ord,Eq)
+
+instance Show JID where
+    show (JID n s r ) = L.unpack $ fmap (<++>"@") n <?++> s <++?> fmap ("/"<++>) r
+
+instance NFData JID where
+    rnf v@(JID n s r) = n `seq` s `seq` r `seq` ()
+
+jid user host rsrc = JID (Just user) host (Just rsrc)
+
+data JabberShow = Offline
+                | Away
+                | Available
+ deriving (Show,Enum,Ord,Eq,Read)
+
+data Presence = Presence JID JabberShow
+
+instance NFData Presence where
+    rnf (Presence jid stat) = rnf jid `seq` stat `seq` ()
 
 
 class XMPPSession session where
@@ -48,6 +75,7 @@ class XMPPSession session where
     setResource  :: session -> ByteString -> IO ()
     getJID       :: session -> IO ByteString
     closeSession :: session -> IO ()
+    subscribeToPresence :: session -> Maybe JID -> IO (TChan Presence)
 
 
 greet host = L.unlines 
diff --git a/Presence/main.hs b/Presence/main.hs
index 4168feca..78ca4363 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -37,7 +37,6 @@ import           Data.Map as Map (Map)
 
 import Control.Concurrent.STM
 import Control.Concurrent (threadDelay)
-import Control.DeepSeq
 import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class
 
@@ -48,34 +47,20 @@ import qualified Prelude
 import           Prelude hiding (putStrLn)
 
 
--- | Jabber ID (JID) datatype
-data JID = JID { name :: Maybe ByteString
-               , server :: ByteString
-               , resource :: Maybe ByteString
-               }
- deriving (Ord,Eq)
-
-instance Show JID where
-    show (JID n s r ) = L.unpack $ fmap (<++>"@") n <?++> s <++?> fmap ("/"<++>) r
-
-instance NFData JID where
-    rnf v@(JID n s r) = n `seq` s `seq` r `seq` ()
-
-jid user host rsrc = JID (Just user) host (Just rsrc)
-
 data UnixSession = UnixSession {
     unix_uid :: (IORef (Maybe UserID)),
-    unix_resource :: (IORef (Maybe L.ByteString))
+    unix_resource :: (IORef (Maybe L.ByteString)),
+    presence_state :: PresenceState
 }
 
 instance XMPPSession UnixSession where
-    data XMPPClass UnixSession = UnixSessions
-    newSession   _ sock handle = do
+    data XMPPClass UnixSession = UnixSessions PresenceState
+    newSession (UnixSessions state) sock handle = do
         muid <- getLocalPeerCred sock
         L.putStrLn $ "SESSION: open " <++> bshow muid
         uid_ref <- newIORef muid
         res_ref <- newIORef Nothing
-        return $ UnixSession uid_ref res_ref
+        return $ UnixSession uid_ref res_ref state
     setResource  s  resource    = do
         writeIORef (unix_resource s) (Just resource)
         L.putStrLn $ "SESSION: resource " <++> resource
@@ -97,17 +82,31 @@ instance XMPPSession UnixSession where
         L.putStrLn $ "SESSION: jid " <++> jid
         return jid
     closeSession _             = L.putStrLn "SESSION: close"
-
-data JabberShow = Offline
-                | Away
-                | Available
- deriving (Show,Enum,Ord,Eq,Read)
-
-data Presence = Presence JID JabberShow
-type MaybePresence = Maybe Presence
-
-instance NFData Presence where
-    rnf (Presence jid stat) = rnf jid `seq` stat `seq` ()
+    subscribeToPresence session Nothing = do
+        let tmvar = greedySubscriber (presence_state session)
+        chan <- atomically $
+            (do (cnt,chan) <- takeTMVar tmvar
+                putTMVar tmvar (cnt+1,chan)
+                return chan )
+          `orElse`
+            (do chan <- newTChan
+                putTMVar tmvar (1,chan)
+                return chan )
+        return chan
+    subscribeToPresence session (Just jid) = do
+        let tvar = subscriberMap (presence_state session)
+        atomically $ do
+            subs <- readTVar tvar
+            let mbchan       = Map.lookup jid subs
+            (chan,subs') <- 
+                do case mbchan of
+                    Nothing -> do
+                      newchan <- newTChan
+                      return (newchan, Map.insert jid (1,newchan) subs)
+                    Just (cnt,chan) -> do
+                      return (chan, Map.insert jid (cnt+1,chan) subs)
+            writeTVar tvar subs'
+            return chan
 
 matchResource tty jid = maybe Away (avail . (==tty)) $ resource jid
  where
@@ -196,7 +195,7 @@ start = do
             utmp_file
             dologin
 #endif
-    sock <- listenForXmppClients UnixSessions 5222 HNil
+    sock <- listenForXmppClients (UnixSessions tracked) 5222 HNil
 
     threadDelay 1000 -- wait a moment to obtain current tty
     dologin ()