Switched from MVar to STM monad.

1 files changed, 37 insertions, 21 deletions

diff --git a/Presence/main.hs b/Presence/main.hs
index e5d3046c..f77e582b 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -34,14 +34,12 @@ import qualified Data.Set as Set
 import           Data.Set as Set (Set,(\\))
 import qualified Data.Map as Map
 import           Data.Map as Map (Map)
-import Control.Concurrent.MVar -- .Strict
+
+import Control.Concurrent.STM
 import Control.Concurrent (threadDelay)
-import Control.Concurrent.Chan
 import Control.DeepSeq
 import Control.Monad.Trans.Maybe
--- import Control.Monad.Trans.Class
 import Control.Monad.IO.Class
--- import Debug.Trace
 
 import ByteStringOperators
 import qualified Data.ByteString.Lazy.Char8 as L
@@ -117,7 +115,7 @@ matchResource tty jid = maybe Away (avail . (==tty)) $ resource jid
     avail False = Away
 
 sendPresence chan jid status = 
-    (liftIO . writeChan chan . Just . Presence jid $ status) :: MaybeT IO ()
+    (liftIO  . atomically . writeTChan chan . Presence jid $ status) :: MaybeT IO ()
 
 lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers 
 
@@ -129,8 +127,21 @@ update_presence subscribers state getStatus =
         sendPresence chan jid status
       putStrLn $ bshow jid <++> " " <++> bshow status
 
-track_login :: MVar (ByteString,Set JID,Map JID (Chan MaybePresence)) -> t -> IO ()
-track_login mvar e = do
+type RefCount = Int
+
+data PresenceState = PresenceState { 
+        currentTTY    :: TVar ByteString,
+        activeUsers   :: TVar (Set JID),
+        subscriberMap :: TVar (Map JID (RefCount,TChan Presence))
+    }
+
+newPresenceState = atomically $ do
+    tty  <- newTVar ""
+    us   <- newTVar (Set.empty)
+    subs <- newTVar (Map.empty)
+    return $ PresenceState tty us subs
+
+track_login state e = do
 #ifndef NOUTMP
     us <- UTmp.users
 #else
@@ -140,26 +151,31 @@ track_login mvar e = do
             if L.take 3 tty == "tty"
               then Just (jid user host tty)
               else Nothing
-        jids = Set.fromList $ mapMaybe (toJabberId "localhost") us
-    (tty,users,subscribers) 
-        <- modifyMVar mvar $ \(tty,st,xs) -> 
-            return ((tty,jids,xs),(tty,st,xs))
-    let arrivals   = jids \\ users
-        departures = users \\ jids
-    update_presence subscribers departures $ const Offline
-    update_presence subscribers arrivals   $ matchResource tty
-
-on_chvt mvar vtnum = do
+        new_users = Set.fromList $ mapMaybe (toJabberId "localhost") us
+    (tty,known_users,subs) <- atomically $ do
+            tty <- readTVar           $ currentTTY state
+            st  <- flip swapTVar new_users $ activeUsers state
+            xs  <- readTVar           $ subscriberMap state
+            return (tty,st,fmap snd xs)
+    let arrivals   = new_users \\ known_users
+        departures = known_users \\ new_users
+    update_presence subs departures $ const Offline
+    update_presence subs arrivals   $ matchResource tty
+
+on_chvt state vtnum = do
     let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum)
     L.putStrLn $ "VT switch: " <++> tty
-    (users,subscribers) <- modifyMVar mvar $ \(_,us,xs) -> do
-                            return ((tty,us,xs),(us,xs))
-    update_presence subscribers users $ matchResource tty
+    (users,subs) <- 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
 
 
 start :: IO ()
 start = do
-    tracked <- newMVar ("",Set.empty,Map.empty)
+    tracked <- newPresenceState
     let dologin e = track_login tracked e
         dologin :: t -> IO ()
     installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing