1 files changed, 51 insertions, 14 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index eb680002..631f97c3 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -15,6 +15,7 @@ module XMPPServer
     , peerKeyToResolvedName
     , addrToText
     , sendModifiedStanzaToPeer
+    , sendModifiedStanzaToClient
     ) where
 import Debug.Trace
 import Control.Monad.Trans.Resource (runResourceT)
@@ -147,7 +148,7 @@ data XMPPServerParameters =
     , xmppTellMyNameToPeer :: SockAddr -> IO Text
     , xmppTellClientHisName :: ConnectionKey -> IO Text
     , xmppTellPeerHisName :: ConnectionKey -> IO Text
-    , xmppNewConnection :: ConnectionKey -> TChan Stanza -> IO ()
+    , xmppNewConnection :: ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
     , xmppEOF :: ConnectionKey -> IO ()
     , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
     , xmppRosterSubscribers  :: ConnectionKey -> IO [Text]
@@ -181,9 +182,10 @@ peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0"
 peerKeyToResolvedName :: ConnectionKey -> IO Text
 peerKeyToResolvedName k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1"
 peerKeyToResolvedName k@(PeerKey { callBackAddress=addr }) = do
-    ent <- getHostByAddr addr --  AF_UNSPEC addr
-    let names = BSD.hostName ent : BSD.hostAliases ent
-        mname = listToMaybe names
+    mname <- handleIO_ (return Nothing) $ do
+        ent <- getHostByAddr addr --  AF_UNSPEC addr
+        let names = BSD.hostName ent : BSD.hostAliases ent
+        return $ listToMaybe names
     return $ maybe (peerKeyToText k) Text.pack mname 
 
 
@@ -278,6 +280,17 @@ sendModifiedStanzaToPeer stanza chan = do
  where
     c = stanzaToConduit stanza =$= swapNamespace "jabber:client" "jabber:server" =$= fixHeaders stanza
 
+sendModifiedStanzaToClient stanza chan = do
+    (echan,clsrs,quitvar) <- conduitToChan c
+    ioWriteChan chan
+        stanza  { stanzaChan = echan
+                , stanzaClosers = clsrs
+                , stanzaInterrupt = quitvar
+                -- TODO id? origin?
+                }
+ where
+    c = stanzaToConduit stanza =$= swapNamespace "jabber:server" "jabber:client" =$= fixHeaders stanza
+
 -- id,to, and from are taken as-is from reply list
 sendReply donevar stype reply replychan = do
     if null reply then return ()
@@ -532,6 +545,7 @@ xmppInbound sv xmpp k laddr pingflag src stanzas output donevar = doNestingXML $
                     pongfrom = maybe me id mto
                     pong = makePong namespace mid pongto pongfrom
                 sendReply donevar Pong pong output
+#ifdef PINGNOISE
                 -- TODO: Remove this, it is only to generate a debug print
                 ioWriteChan stanzas Stanza
                             { stanzaType = Ping
@@ -543,6 +557,7 @@ xmppInbound sv xmpp k laddr pingflag src stanzas output donevar = doNestingXML $
                             , stanzaInterrupt = donevar
                             , stanzaOrigin = NetworkOrigin k output
                             }
+#endif
               stype -> ioWriteChan stanzas Stanza
                             { stanzaType = stype
                             , stanzaId = mid
@@ -745,10 +760,20 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
         fix $ \loop -> do
             what <- atomically $ foldr1 orElse
                 [readTChan output >>= \stanza -> return $ do
-                    dup <- atomically $ cloneStanza stanza
-                    stanzaToConduit dup $$ prettyPrint $ case k of
-                        ClientKey {} -> "C<-" <> bshow (stanzaType dup) <> " "
-                        PeerKey {}   -> "P<-" <> bshow (stanzaType dup) <> " "
+#ifndef PINGNOISE
+                    let notping f = case stanzaType stanza of Pong -> return ()
+                                                              _ -> f
+#else
+                    let notping f = f
+#endif
+                    notping $ do
+                        dup <- atomically $ cloneStanza stanza
+                        let typ = Strict8.pack $ c ++ "<-"++(concat . take 1 . words $ show (stanzaType dup))++" "
+                            c = case k of
+                                    ClientKey {} -> "C"
+                                    PeerKey {}   -> "P"
+                        wlog ""
+                        stanzaToConduit dup $$ prettyPrint typ
                     stanzaToConduit stanza
                         $$ awaitForever
                             $ liftIO . atomically . Slotted.push slots Nothing
@@ -762,10 +787,12 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
                         ping = makePing namespace mid to from
                     mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
                           ping
+#ifdef PINGNOISE
                     wlog ""
                     CL.sourceList ping $$ prettyPrint $ case k of
                         ClientKey {} -> "C<-Ping"
                         PeerKey {} -> "P<-Ping "
+#endif
                     loop
                 ,readTMVar rdone >> return (return ())
                 ]
@@ -912,7 +939,7 @@ monitor sv params xmpp = do
                  wlog $ tomsg k "Connection"
                  let (xsrc,xsnk) = xmlStream conread conwrite
                  outs <- forkConnection sv xmpp k u pingflag xsrc xsnk stanzas
-                 xmppNewConnection xmpp k outs
+                 xmppNewConnection xmpp k u outs
                  return ()
             ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure"
             EOF        -> do wlog $ tomsg k "EOF"
@@ -924,7 +951,17 @@ monitor sv params xmpp = do
             RequiresPing -> return () -- wlog $ tomsg k "RequiresPing"
             _ -> return ()
       , readTChan stanzas >>= \stanza -> return $ do
+        dup <- case stanzaType stanza of
+                Message {} -> do
+                    dup <- atomically $ cloneStanza stanza -- dupped so we can make debug print
+                    return dup
+                _ -> return stanza
         forkIO $ do
+            case stanzaType stanza of
+                Message {} -> do
+                    let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
+                    xmppDeliverMessage xmpp fail stanza
+                _ -> return ()
             case stanzaOrigin stanza of
                 NetworkOrigin k@(ClientKey {}) replyto -> 
                     case stanzaType stanza of
@@ -940,10 +977,6 @@ monitor sv params xmpp = do
                         RequestRoster -> do
                             sendRoster stanza xmpp replyto
                             xmppSubscribeToRoster xmpp k
-                        Message {} -> do
-                            let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
-                            stanza2 <- atomically $ cloneStanza stanza
-                            xmppDeliverMessage xmpp fail stanza
                         PresenceStatus {} -> do
                             xmppInformClientPresence xmpp k stanza
                         UnrecognizedQuery query -> do
@@ -953,7 +986,11 @@ monitor sv params xmpp = do
                         _ -> return ()
                 _ -> return ()
         -- We need to clone in the case the stanza is passed on as for Message.
-        dup <- atomically $ cloneStanza stanza
+#ifndef PINGNOISE
+        let notping f = case stanzaType stanza of Pong -> return ()
+                                                  _ -> f
+        notping $ do
+#endif
         let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
             c = case stanzaOrigin stanza of
                     LocalPeer -> "*"