xmppTellMyName

1 files changed, 15 insertions, 8 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 222d8ac4..96998198 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -122,6 +122,8 @@ data Stanza = Stanza
 data XMPPServerParameters =
     XMPPServerParameters
     { xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> IO Text
+    , xmppTellMyNameToClient :: IO Text
+    , xmppTellMyNameToPeer :: SockAddr -> IO Text
     , xmppNewConnection :: ConnectionKey -> TChan Stanza -> IO ()
     , xmppEOF :: ConnectionKey -> IO ()
     , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
@@ -618,22 +620,25 @@ goodbye =
     ]
 
 forkConnection :: Server ConnectionKey SockAddr
+                -> XMPPServerParameters
                 -> ConnectionKey
+                -> SockAddr
                 -> FlagCommand
                 -> Source IO XML.Event
                 -> Sink (Flush XML.Event) IO ()
                 -> TChan Stanza
                 ->  IO (TChan Stanza)
-forkConnection sv k pingflag src snk stanzas = do
-    let namespace = case k of
-                        ClientKey {} -> "jabber:client"
-                        PeerKey {} -> "jabber:server"
+forkConnection sv xmpp k laddr pingflag src snk stanzas = do
+    let (namespace,tellmyname) = case k of
+                        ClientKey {} -> ("jabber:client", xmppTellMyNameToClient xmpp)
+                        PeerKey {} -> ("jabber:server",xmppTellMyNameToPeer xmpp laddr)
+    me <- tellmyname
     rdone <- atomically newEmptyTMVar
     slots <- atomically $ Slotted.new isEventBeginElement isEventEndElement
     needsFlush <- atomically $ newTVar False
     let _ = slots :: Slotted.UpdateStream XMPPState XML.Event
     let greet_src = do
-            CL.sourceList (greet' namespace "localhost") =$= CL.map Chunk
+            CL.sourceList (greet' namespace me) =$= CL.map Chunk
             yield Flush
         slot_src = do
             what <- lift . atomically $ foldr1 orElse
@@ -823,7 +828,7 @@ monitor sv params xmpp = do
             Connection pingflag conread conwrite -> do
                  wlog $ tomsg k "Connection"
                  let (xsrc,xsnk) = xmlStream conread conwrite
-                 outs <- forkConnection sv k pingflag xsrc xsnk stanzas
+                 outs <- forkConnection sv xmpp k u pingflag xsrc xsnk stanzas
                  xmppNewConnection xmpp k outs
                  return ()
             ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure"
@@ -846,7 +851,8 @@ monitor sv params xmpp = do
                             let reply = iq_bind_reply (stanzaId stanza) rsc
                             sendReply quitVar SetResource reply replyto
                         SessionRequest -> do
-                            let reply = iq_session_reply (stanzaId stanza) "localhost"
+                            me <- xmppTellMyNameToClient xmpp
+                            let reply = iq_session_reply (stanzaId stanza) me
                             sendReply quitVar Pong reply replyto
                         RequestRoster -> do
                             sendRoster stanza xmpp replyto
@@ -857,7 +863,8 @@ monitor sv params xmpp = do
                         PresenceStatus {} -> do
                             xmppInformClientPresence xmpp k stanza
                         UnrecognizedQuery query -> do
-                            let reply = iq_service_unavailable (stanzaId stanza) "localhost" query
+                            me <- xmppTellMyNameToClient xmpp
+                            let reply = iq_service_unavailable (stanzaId stanza) me query
                             sendReply quitVar Error reply replyto
                         _ -> return ()
                 _ -> return ()