From 31aee2ac1bf2eb4ad1b2725659f6e6695c2f84d3 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Tue, 18 Jun 2013 22:59:35 -0400
Subject: greedy subscriber capability

---
 Presence/main.hs | 37 ++++++++++++++++++++++---------------
 1 file changed, 22 insertions(+), 15 deletions(-)

(limited to 'Presence')

diff --git a/Presence/main.hs b/Presence/main.hs
index f77e582b..4168feca 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -119,27 +119,32 @@ sendPresence chan jid status =
 
 lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers 
 
-update_presence subscribers state getStatus =
+update_presence greedy subscribers state getStatus =
     forM_ (Set.toList state) $ \jid -> do
       let status = getStatus jid 
       runMaybeT $ do
         chan <- lookupT jid subscribers
         sendPresence chan jid status
+      runMaybeT $ do
+        chan <- MaybeT . return $ greedy
+        sendPresence chan jid status
       putStrLn $ bshow jid <++> " " <++> bshow status
 
 type RefCount = Int
 
-data PresenceState = PresenceState { 
-        currentTTY    :: TVar ByteString,
-        activeUsers   :: TVar (Set JID),
-        subscriberMap :: TVar (Map JID (RefCount,TChan Presence))
+data PresenceState = PresenceState 
+    { currentTTY    :: TVar ByteString
+    , activeUsers   :: TVar (Set JID)
+    , subscriberMap :: TVar (Map JID (RefCount,TChan Presence))
+    , greedySubscriber :: TMVar (RefCount,TChan Presence)
     }
 
 newPresenceState = atomically $ do
     tty  <- newTVar ""
     us   <- newTVar (Set.empty)
     subs <- newTVar (Map.empty)
-    return $ PresenceState tty us subs
+    greedy <- newEmptyTMVar
+    return $ PresenceState tty us subs greedy
 
 track_login state e = do
 #ifndef NOUTMP
@@ -152,25 +157,27 @@ track_login state e = do
               then Just (jid user host tty)
               else Nothing
         new_users = Set.fromList $ mapMaybe (toJabberId "localhost") us
-    (tty,known_users,subs) <- atomically $ do
-            tty <- readTVar           $ currentTTY state
+    (tty,known_users,subs,greedy) <- atomically $ do
+            tty <- readTVar                $ currentTTY state
             st  <- flip swapTVar new_users $ activeUsers state
-            xs  <- readTVar           $ subscriberMap state
-            return (tty,st,fmap snd xs)
+            xs  <- readTVar                $ subscriberMap state
+            greedy <- tryReadTMVar $ greedySubscriber state
+            return (tty,st,fmap snd xs,fmap snd greedy)
     let arrivals   = new_users \\ known_users
         departures = known_users \\ new_users
-    update_presence subs departures $ const Offline
-    update_presence subs arrivals   $ matchResource tty
+    update_presence greedy subs departures $ const Offline
+    update_presence greedy subs arrivals   $ matchResource tty
 
 on_chvt state vtnum = do
     let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum)
     L.putStrLn $ "VT switch: " <++> tty
-    (users,subs) <- atomically $ do
+    (users,subs,greedy) <- atomically $ do
         us   <- readTVar $ activeUsers state
         subs <- readTVar $ subscriberMap state
         writeTVar (currentTTY state) tty
-        return (us,fmap snd subs)
-    update_presence subs users $ matchResource tty
+        greedy <- tryReadTMVar $ greedySubscriber state
+        return (us,fmap snd subs,fmap snd greedy)
+    update_presence greedy subs users $ matchResource tty
 
 
 start :: IO ()
-- 
cgit v1.2.3