Subscriber channels.

1 files changed, 54 insertions, 27 deletions

diff --git a/Presence/main.hs b/Presence/main.hs
index cf5942df..e5d3046c 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -32,10 +32,16 @@ import LocalPeerCred
 import System.Posix.User
 import qualified Data.Set as Set
 import           Data.Set as Set (Set,(\\))
-import Control.Concurrent.MVar.Strict
+import qualified Data.Map as Map
+import           Data.Map as Map (Map)
+import Control.Concurrent.MVar -- .Strict
 import Control.Concurrent (threadDelay)
+import Control.Concurrent.Chan
 import Control.DeepSeq
-import Debug.Trace
+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
@@ -94,10 +100,39 @@ instance XMPPSession UnixSession where
         return jid
     closeSession _             = L.putStrLn "SESSION: close"
 
-track_login :: MVar (ByteString,Set JID) -> t -> IO ()
-track_login tracked e = do
+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` ()
+
+matchResource tty jid = maybe Away (avail . (==tty)) $ resource jid
+ where
+    avail True  = Available
+    avail False = Away
+
+sendPresence chan jid status = 
+    (liftIO . writeChan chan . Just . Presence jid $ status) :: MaybeT IO ()
+
+lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers 
+
+update_presence subscribers state getStatus =
+    forM_ (Set.toList state) $ \jid -> do
+      let status = getStatus jid 
+      runMaybeT $ do
+        chan <- lookupT jid subscribers
+        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
 #ifndef NOUTMP
-    us <- users
+    us <- UTmp.users
 #else
     let us = []
 #endif
@@ -105,34 +140,26 @@ track_login tracked e = do
             if L.take 3 tty == "tty"
               then Just (jid user host tty)
               else Nothing
-        ids = Set.fromList $ mapMaybe (toJabberId "localhost") us
-    (tty,state) <- modifyMVar tracked $ \(tty,st) ->
-                    return ((tty,ids),(tty,st))
-    let arrivals   = ids \\ state
-        departures = state \\ ids
-    forM_ (Set.toList departures) $ \id -> do
-        putStrLn $ bshow id <++> " Offline."
-    forM_ (Set.toList arrivals) $ \jid -> do
-      case fmap (==tty) $ resource jid of
-        Just True  -> putStrLn $ bshow jid <++> " Available."
-        Just False -> putStrLn $ bshow jid <++> " Away."
-        Nothing    -> trace "Unexpected lack of resource" $ return ()
-
-on_chvt tracked vtnum = do
+        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
     let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum)
     L.putStrLn $ "VT switch: " <++> tty
-    state <- modifyMVar tracked $ \(_,us) -> do
-                return ((tty,us),us)
-    forM_ (Set.toList state) $ \jid -> do
-      case fmap (==tty) $ resource jid of
-        Just True  -> putStrLn $ bshow jid <++> " Available."
-        Just False -> putStrLn $ bshow jid <++> " Away."
-        Nothing    -> return ()
+    (users,subscribers) <- modifyMVar mvar $ \(_,us,xs) -> do
+                            return ((tty,us,xs),(us,xs))
+    update_presence subscribers users $ matchResource tty
 
 
 start :: IO ()
 start = do
-    tracked <- newMVar ("",Set.empty)
+    tracked <- newMVar ("",Set.empty,Map.empty)
     let dologin e = track_login tracked e
         dologin :: t -> IO ()
     installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing