xmppServer method now returns opague data structure XMPPServer

2 files changed, 24 insertions, 9 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 96998198..421648fb 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -3,6 +3,8 @@ module XMPPServer
     ( xmppServer
     , ConnectionKey(..)
     , XMPPServerParameters(..)
+    , XMPPServer
+    , addPeer
     , Stanza(..)
     , StanzaType(..)
     , StanzaOrigin(..)
@@ -210,6 +212,7 @@ prettyPrint prefix =
         =$= CB.lines 
         =$ CL.mapM_ (wlogb . (prefix <>))
 
+-- id,to, and from are taken as-is from reply list
 sendReply donevar stype reply replychan = do
     if null reply then return ()
     else do
@@ -222,8 +225,8 @@ sendReply donevar stype reply replychan = do
         replyClsrs <- newTVar (Just [])
         return Stanza { stanzaType = stype
                       , stanzaId = mid
-                      , stanzaTo = mto      -- todo: should this be reversed?
-                      , stanzaFrom = mfrom  -- todo: should this be reversed?
+                      , stanzaTo = mto      -- as-is from reply list
+                      , stanzaFrom = mfrom  -- as-is from reply list
                       , stanzaChan = replyChan
                       , stanzaClosers = replyClsrs
                       , stanzaInterrupt = donevar
@@ -884,9 +887,18 @@ monitor sv params xmpp = do
         where
             _ = str :: String
 
+data XMPPServer
+    = XMPPServer { _xmpp_sv :: Server ConnectionKey SockAddr
+                 , _xmpp_peer_params :: ConnectionParameters ConnectionKey SockAddr
+                 }
+
+addPeer :: XMPPServer -> SockAddr -> IO ()
+addPeer sv addr = do
+    control (_xmpp_sv sv) (ConnectWithEndlessRetry addr (_xmpp_peer_params sv) 10000)
+
 xmppServer :: ( MonadResource m
               , MonadIO m
-              ) => XMPPServerParameters -> m (Server ConnectionKey SockAddr,ConnectionParameters ConnectionKey SockAddr)
+              ) => XMPPServerParameters -> m XMPPServer
 xmppServer xmpp = do
     sv <- server
     -- some fuzz helps avoid simultaneity
@@ -906,4 +918,4 @@ xmppServer xmpp = do
         forkIO $ monitor sv peer_params xmpp
         control sv (Listen peerport peer_params)
         control sv (Listen clientport client_params)
-    return (sv,peer_params)
+    return XMPPServer { _xmpp_sv = sv, _xmpp_peer_params = peer_params }
diff --git a/xmppServer.hs b/xmppServer.hs
index d67b7552..464d3b1d 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -11,18 +11,21 @@ import Network.Socket
     , AddrInfoFlag(AI_CANONNAME)
     )
 import Data.Monoid ( (<>) )
+import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
 import Control.Monad
+import qualified Network.BSD as BSD
 
 
 import XMPPServer
 import Server
 
 main = runResourceT $ do
-    (sv,peer_params) <- xmppServer
+    hostname <- fmap Text.pack $ liftIO BSD.getHostName
+    sv <- xmppServer
         XMPPServerParameters
-        { xmppChooseResourceName = \k sock desired -> return "nobody@localhost/tty666"
-        , xmppTellMyNameToClient = return "localhost"
+        { xmppChooseResourceName = \k sock desired -> return $ "nobody@" <> hostname <> "/tty666"
+        , xmppTellMyNameToClient = return hostname
         , xmppTellMyNameToPeer = \addr -> return "localhost"
         , xmppNewConnection = \k outchan -> return ()
         , xmppEOF = \k -> return ()
@@ -32,7 +35,7 @@ main = runResourceT $ do
         , xmppRosterOthers = \k -> return []
         , xmppSubscribeToRoster = \k -> return ()
         , xmppLookupPeerName = \k ->  return "localhost"
-        , xmppLookupClientJID = \k -> return "nobody@localhost/tty666"
+        , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666"
         , xmppDeliverMessage = \fail msg -> do
             let msgs = msgLangMap (stanzaType msg)
                 body = fmap (maybe "" id . msgBody . snd) $ take 1 msgs
@@ -49,7 +52,7 @@ main = runResourceT $ do
                 (Just testaddr0)
                 (Just "5269")
     putStrLn $ "Connecting to "++show testaddr
-    control sv (ConnectWithEndlessRetry testaddr peer_params 10000)
+    addPeer sv testaddr
 
     quitVar <- newEmptyTMVarIO
     installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing