Work toward sending outgoing messages to remote peers

1 files changed, 76 insertions, 2 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 7e42c7ae..062fcacb 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -6,6 +6,7 @@
 -- {-# LANGUAGE GADTs               #-}
 module XMPPServer where -- ( listenForXmppClients ) where
 
+import Todo
 import Data.HList.TypeEqGeneric1()
 import Data.HList.TypeCastGeneric1()
 import ByteStringOperators
@@ -14,6 +15,7 @@ import Server
 import Data.ByteString.Lazy.Char8 as L 
     ( hPutStrLn
     , unlines
+    , splitWith
     , ByteString
     , pack
     , unpack )
@@ -47,6 +49,8 @@ import Control.Exception
 import Text.Show.ByteString as L
 import Data.Binary.Builder as B
 import Data.Binary.Put
+import qualified Data.Map as Map
+import GHC.Conc
 
 -- | Jabber ID (JID) datatype
 data JID = JID { name :: Maybe ByteString
@@ -98,6 +102,9 @@ class XMPPSession session where
     closeSession :: session -> IO ()
     subscribe :: session -> Maybe JID -> IO (TChan Presence)
 
+class XMPPConfig config where
+    getBuddies :: config -> ByteString -> IO [ByteString]
+    getSubscribers :: config -> ByteString -> IO [ByteString]
 
 greet host = L.unlines 
     [ "<?xml version='1.0'?>"
@@ -353,5 +360,72 @@ listenForRemotePeers session_factory port st = do
              dopkt
              start
 
-seekRemotePeers session_factory st = do
-    return ()
+newServerConnections = atomically $ newTVar Map.empty
+{-
+sendMessage cons msg peer = do
+    (is_new,entry) <- atomically $ do
+        consmap <- readTVar cons
+        let found = Map.lookup peer consmap
+            newEntry = ()
+            entry = maybe newEntry id found
+            is_new = isNothing found
+        when is_new
+          $ writeTVar cons (Map.insert peer entry consmap)
+        return (is_new,entry)
+    L.putStrLn $ "sendMessage ->"<++>peer<++>": "<++>bshow msg
+    when is_new $ connect_to_server entry peer
+
+-}
+
+sendMessage cons msg peer = do
+    found <- atomically $ do
+        consmap <- readTVar cons
+        return (Map.lookup peer consmap)
+    let newEntry = do
+          chan <- atomically newTChan
+          t <- forkIO $ connect_to_server chan peer
+          return (chan,t) 
+    entry <- maybe newEntry
+          ( \(chan,t) -> do 
+                        st <- threadStatus t
+                        case st of 
+                          ThreadRunning -> return (chan,t)
+                          _             -> newEntry 
+                        )
+          found
+    L.putStrLn $ "sendMessage ->"<++>peer<++>": "<++>bshow msg
+
+connect_to_server chan peer = return ()
+
+parseJID :: ByteString -> JID
+parseJID bjid = 
+    let xs = L.splitWith (=='@') bjid
+        ys = L.splitWith (=='/') (last xs)
+        (name,server) 
+            = case xs of
+                (n:s:_) -> (Just n,s)
+                (s:_)   -> (Nothing,s)
+        rsrc = case ys of
+                (s:_:_) -> Just $ last ys
+                _       -> Nothing
+    in JID name server rsrc
+
+seekRemotePeers :: XMPPConfig config =>
+     (ByteString -> Bool) -> config -> TChan Presence -> IO b0
+seekRemotePeers is_peer config chan = do
+    server_connections <- newServerConnections
+    fix $ \loop -> do
+        event <- atomically $ readTChan chan
+        case event of
+            p@(Presence jid stat) -> do
+              L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
+              runMaybeT $ 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
+                    when (is_peer peer) $
+                        liftIO $ sendMessage server_connections p peer
+        loop