Work toward sending outgoing messages to remote peers

3 files changed, 95 insertions, 7 deletions

diff --git a/Presence/ConfigFiles.hs b/Presence/ConfigFiles.hs
index ee0d5b85..f0e18f70 100644
--- a/Presence/ConfigFiles.hs
+++ b/Presence/ConfigFiles.hs
@@ -54,10 +54,12 @@ addSubscriber :: User -> ByteString -> IO ()
 addSubscriber user subscriber =
     subscriberPath user >>= addItem subscriber "<? subscribers ?>"
 
-getConfigList path = withFile path ReadMode $
-    L.hGetContents 
-    >=> return . Prelude.tail . L.lines 
-    >=> (\a -> seq (rnf a) (return a))
+getConfigList path = 
+  handle (\e -> if isDoesNotExistError e then (return []) else throw e)
+    $ withFile path ReadMode $
+        L.hGetContents 
+        >=> return . Prelude.tail . L.lines 
+        >=> (\a -> seq (rnf a) (return a))
 
 getBuddies :: User -> IO [ByteString]
 getBuddies user = buddyPath user >>= getConfigList
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 
diff --git a/Presence/main.hs b/Presence/main.hs
index e416d7cc..b0721292 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE TypeFamilies      #-}
 module Main where
 
+import Debug.Trace
 import System.Directory
 import Control.Monad
 import System.Posix.Signals
@@ -10,6 +11,7 @@ import System.Posix.Types
 import System.Posix.Process
 import Data.Maybe
 import Data.Char
+import ConfigFiles
 
 import System.INotify
 #ifndef NOUTMP
@@ -36,7 +38,7 @@ import qualified Data.Map as Map
 import           Data.Map as Map (Map)
 
 import Control.Concurrent.STM
-import Control.Concurrent (threadDelay)
+import Control.Concurrent
 import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class
 
@@ -187,12 +189,21 @@ on_chvt state vtnum = do
         return (us,fmap snd subs,fmap snd greedy)
     update_presence greedy subs users $ matchResource tty
 
+data UnixConfig = UnixConfig
+
+instance XMPPConfig UnixConfig where
+    getBuddies     _ user = ConfigFiles.getBuddies user
+    getSubscribers _ user = ConfigFiles.getSubscribers user
 
 start :: ByteString -> IO ()
 start host = do
     tracked <- newPresenceState host
     let dologin e = track_login host tracked e
         dologin :: t -> IO ()
+
+    chan <- atomically $ subscribeToChan (greedySubscriber tracked)
+    remotes <- forkIO $ seekRemotePeers (/=host) UnixConfig chan
+
     installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
     -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
     mtty <- monitorTTY (on_chvt tracked)
@@ -211,6 +222,7 @@ start host = do
     dologin ()
     putStrLn "\nHit enter to terminate...\n"
     getLine
+    killThread remotes
     sClose sockLocals
     sClose sockRemotes
     -- threadDelay 1000