2 files changed, 36 insertions, 16 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 421648fb..45dc282e 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -10,6 +10,8 @@ module XMPPServer
     , StanzaOrigin(..)
     , cloneStanza
     , LangSpecificMessage(..)
+    , peerKeyToText
+    , addrToText
     ) where
 import Debug.Trace
 import Control.Monad.Trans.Resource (runResourceT)
@@ -126,6 +128,8 @@ data XMPPServerParameters =
     { xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> IO Text
     , xmppTellMyNameToClient :: IO Text
     , xmppTellMyNameToPeer :: SockAddr -> IO Text
+    , xmppTellClientHisName :: ConnectionKey -> IO Text
+    , xmppTellPeerHisName :: ConnectionKey -> IO Text
     , xmppNewConnection :: ConnectionKey -> TChan Stanza -> IO ()
     , xmppEOF :: ConnectionKey -> IO ()
     , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
@@ -153,6 +157,10 @@ addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr)
           where
             (pre,bracket) = break (==']') s
 
+peerKeyToText :: ConnectionKey -> Text
+peerKeyToText (PeerKey { callBackAddress=addr }) = addrToText addr
+peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt"
+
 wlog s = putStrLn s
  where _ = s :: String
 wlogb s = Strict8.putStrLn s
@@ -402,17 +410,27 @@ grokStanza "jabber:client" stanzaTag =
                 _ -> return $ Just Unrecognized
 
 xmppInbound :: Server ConnectionKey SockAddr
+                -> XMPPServerParameters
                 -> ConnectionKey
+                -> SockAddr
                 -> FlagCommand 
                 -> Source IO XML.Event
                 -> TChan Stanza
                 -> TChan Stanza
                 -> TMVar ()
                 -> Sink XML.Event IO ()
-xmppInbound sv k pingflag src stanzas output donevar = doNestingXML $ do
-    let namespace = case k of
-                        ClientKey {} -> "jabber:client"
-                        PeerKey {} -> "jabber:server"
+xmppInbound sv xmpp k laddr pingflag src stanzas output donevar = doNestingXML $ do
+    let (namespace,tellmyname,tellyourname) = case k of
+            ClientKey {} -> ( "jabber:client"
+                            , xmppTellMyNameToClient xmpp
+                            , xmppTellClientHisName xmpp k
+                            )
+            PeerKey {} -> ( "jabber:server"
+                          , xmppTellMyNameToPeer xmpp laddr
+                          , xmppTellPeerHisName xmpp k
+                          )
+    me <- liftIO tellmyname
+    you <- liftIO tellyourname
     withXML $ \begindoc -> do
     when (begindoc==EventBeginDocument) $ do
     whenJust nextElement $ \xml -> do
@@ -447,13 +465,13 @@ xmppInbound sv k pingflag src stanzas output donevar = doNestingXML $ do
                 ioWriteChan stanzas s
           flip (maybe $ unrecog) dispatch $ \dispatch -> 
             case dispatch of
-              Ping -> do
-                -- TODO: check that the to-address matches this server.
-                -- Otherwise it could be a client-to-client ping or a
-                -- client-to-server for some other server.
-                -- For now, assuming its for the immediate connection.
-                let pongto = maybe "todo" id mfrom
-                    pongfrom = maybe "todo" id mto
+              -- Checking that the to-address matches this server.
+              -- Otherwise it could be a client-to-client ping or a
+              -- client-to-server for some other server.
+              -- For now, assuming its for the immediate connection.
+              Ping | mto==Just me || mto==Nothing -> do
+                let pongto = maybe you id mfrom
+                    pongfrom = maybe me id mto
                     pong = makePong namespace mid pongto pongfrom
                 sendReply donevar Pong pong output
                 -- TODO: Remove this, it is only to generate a debug print
@@ -679,9 +697,9 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
                     loop
                 ,do pingflag >>= check
                     return $ do
-                    let to = addrToText (callBackAddress k)
-                        from = "todo" -- Look it up from Server object
-                                      -- or pass it with Connection event.
+                    to <- xmppTellPeerHisName xmpp k -- addrToText (callBackAddress k)
+                    let from = me -- Look it up from Server object
+                                  -- or pass it with Connection event.
                         mid = Just "ping"
                         ping = makePing namespace mid to from
                     mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
@@ -697,7 +715,7 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
         wlog $ "end pre-queue fork: " ++ show k
     forkIO $ do
         -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        src $$ xmppInbound sv k pingflag src stanzas output rdone
+        src $$ xmppInbound sv xmpp k laddr pingflag src stanzas output rdone
         atomically $ putTMVar rdone ()
         wlog $ "end reader fork: " ++ show k
     return output
diff --git a/xmppServer.hs b/xmppServer.hs
index 464d3b1d..3a16aca5 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -26,7 +26,9 @@ main = runResourceT $ do
         XMPPServerParameters
         { xmppChooseResourceName = \k sock desired -> return $ "nobody@" <> hostname <> "/tty666"
         , xmppTellMyNameToClient = return hostname
-        , xmppTellMyNameToPeer = \addr -> return "localhost"
+        , xmppTellMyNameToPeer = \addr -> return $ addrToText addr
+        , xmppTellClientHisName = \k -> return $ "nobody@" <> hostname <> "/tty666"
+        , xmppTellPeerHisName = return . peerKeyToText
         , xmppNewConnection = \k outchan -> return ()
         , xmppEOF = \k -> return ()
         , xmppRosterBuddies = \k -> return []