announcePresence interface

2 files changed, 47 insertions, 20 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 4f61646f..387b223e 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -59,6 +59,7 @@ import qualified Data.Map as Map
 import GHC.Conc
 import Network.BSD
 import Control.Concurrent.Async
+import qualified Data.Set as Set
 
 -- | Jabber ID (JID) datatype
 data JID = JID { name :: Maybe ByteString
@@ -109,6 +110,7 @@ class XMPPSession session where
     getJID       :: session -> IO JID
     closeSession :: session -> IO ()
     subscribe :: session -> Maybe JID -> IO (TChan Presence)
+    announcePresence :: session -> Presence -> IO ()
 
 class XMPPConfig config where
     getBuddies :: config -> ByteString -> IO [ByteString]
@@ -354,10 +356,31 @@ startPeer session_factory sock st = do
     name <- fmap bshow $ getPeerName sock
     L.putStrLn $ "REMOTE-IN: connected " <++> name
     let quit = L.putStrLn $ "REMOTE-IN: disconnected " <++> name
-    return ( ConnectionFinalizer quit .*. st )
+    session <- newSession session_factory sock h
+    return ( session .*. ConnectionFinalizer quit .*. st )
 
 doPeer st elem cont = do
+    let session = hHead st
     L.putStrLn $ "REMOTE-IN: received " <++> bshow elem
+    case elem of
+      Element e@(Elem (N "presence") attrs content) -> do
+        let jid = fmap pack (lookup (N "from") attrs >>= unattr)
+            typ = fmap pack (lookup (N "type") attrs >>= unattr)
+        case (jid,typ) of
+          (Just jid,Just "unavailable") -> do
+            L.putStrLn $ "INBOUND PRESENCE! Offline jid=" <++> jid
+            announcePresence session (Presence (parseJID jid) Offline)
+          (Just jid,Just typ) -> 
+            -- possible probe, ignored for now
+            L.putStrLn $ "INBOUND PRESENCE! "<++>typ<++>" jid="<++>jid
+          (Just jid,Nothing) -> do
+            let string (CString _ s _) = [s]
+                show = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content
+
+            -- Available or Away.
+            L.putStrLn $ "INBOUND PRESENCE! avail/away jid=" <++> jid
+            -- todo: announcePresence
+      _ -> return () -- putStrLn $ "inbound unhandled: "++show v
     cont ()
 
 xmlLexPartial name cs =
@@ -448,9 +471,11 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
                 cached_map <- readIORef cached
                 writeIORef cached (Map.insert jid st cached_map)
                 loop
+            {-
             Left event -> do
                 L.putStrLn $ "REMOTE-OUT DISCARDED: " <++> bshow event
                 loop
+            -}
             Right sock -> return sock
 
     liftIO $ do
@@ -534,9 +559,8 @@ seekRemotePeers is_peer config chan = do
                   u <- MaybeT . return $ name jid
                   subscribers <- liftIO $ getSubscribers config u
                   liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers
-                  forM_ subscribers $ \bjid -> do
-                    let jid = parseJID bjid
-                        peer = server jid
+                  let peers = Set.map (server . parseJID) (Set.fromList subscribers)
+                  forM_ (Set.toList peers) $ \peer -> do
                     when (is_peer peer) $
                         liftIO $ sendMessage server_connections (OutBoundPresence p) peer
         loop 
diff --git a/Presence/main.hs b/Presence/main.hs
index b0721292..ed247bca 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -87,11 +87,14 @@ instance XMPPSession UnixSession where
         return (JID (Just user) host rsc)
     closeSession _             = L.putStrLn "SESSION: close"
     subscribe session Nothing = do
-        let tmvar = greedySubscriber (presence_state session)
+        let tmvar = localSubscriber (presence_state session)
         atomically $ subscribeToChan tmvar
     subscribe session (Just jid) = do
         let tvar = subscriberMap (presence_state session)
         atomically $ subscribeToMap tvar jid
+    announcePresence session (Presence jid status) = do
+        subs <- readTVarIO $ subscriberMap (presence_state session)
+        update_presence Nothing (fmap snd subs) (Set.singleton jid) (const status)
 
 
 subscribeToChan tmvar =
@@ -128,14 +131,14 @@ sendPresence chan jid status =
 
 lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers 
 
-update_presence greedy subscribers state getStatus =
+update_presence locals_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
+        chan <- MaybeT . return $ locals_greedy
         sendPresence chan jid status
       putStrLn $ bshow jid <++> " " <++> bshow status
 
@@ -146,15 +149,15 @@ data PresenceState = PresenceState
     , currentTTY    :: TVar ByteString
     , activeUsers   :: TVar (Set JID)
     , subscriberMap :: TVar (Map JID (RefCount,TChan Presence))
-    , greedySubscriber :: TMVar (RefCount,TChan Presence)
+    , localSubscriber :: TMVar (RefCount,TChan Presence)
     }
 
 newPresenceState hostname = atomically $ do
     tty  <- newTVar ""
     us   <- newTVar (Set.empty)
     subs <- newTVar (Map.empty)
-    greedy <- newEmptyTMVar
-    return $ PresenceState hostname tty us subs greedy
+    locals_greedy <- newEmptyTMVar
+    return $ PresenceState hostname tty us subs locals_greedy
 
 track_login host state e = do
 #ifndef NOUTMP
@@ -167,27 +170,27 @@ track_login host state e = do
               then Just (jid user host tty)
               else Nothing
         new_users = Set.fromList $ mapMaybe (toJabberId host) us
-    (tty,known_users,subs,greedy) <- atomically $ do
+    (tty,known_users,subs,locals_greedy) <- atomically $ do
             tty <- readTVar                $ currentTTY state
             st  <- flip swapTVar new_users $ activeUsers state
             xs  <- readTVar                $ subscriberMap state
-            greedy <- tryReadTMVar $ greedySubscriber state
-            return (tty,st,fmap snd xs,fmap snd greedy)
+            locals_greedy <- tryReadTMVar $ localSubscriber state
+            return (tty,st,fmap snd xs,fmap snd locals_greedy)
     let arrivals   = new_users \\ known_users
         departures = known_users \\ new_users
-    update_presence greedy subs departures $ const Offline
-    update_presence greedy subs arrivals   $ matchResource tty
+    update_presence locals_greedy subs departures $ const Offline
+    update_presence locals_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,greedy) <- atomically $ do
+    (users,subs,locals_greedy) <- atomically $ do
         us   <- readTVar $ activeUsers state
         subs <- readTVar $ subscriberMap state
         writeTVar (currentTTY state) tty
-        greedy <- tryReadTMVar $ greedySubscriber state
-        return (us,fmap snd subs,fmap snd greedy)
-    update_presence greedy subs users $ matchResource tty
+        locals_greedy <- tryReadTMVar $ localSubscriber state
+        return (us,fmap snd subs,fmap snd locals_greedy)
+    update_presence locals_greedy subs users $ matchResource tty
 
 data UnixConfig = UnixConfig
 
@@ -201,7 +204,7 @@ start host = do
     let dologin e = track_login host tracked e
         dologin :: t -> IO ()
 
-    chan <- atomically $ subscribeToChan (greedySubscriber tracked)
+    chan <- atomically $ subscribeToChan (localSubscriber tracked)
     remotes <- forkIO $ seekRemotePeers (/=host) UnixConfig chan
 
     installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing