announcePresence interface

1 files changed, 28 insertions, 4 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