From a41ffe16f5f3237a0b16c49f743ba423b19e46d6 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Thu, 6 Mar 2014 00:53:30 -0500
Subject: multiply presence for client (for hostname aliases)

---
 Presence/XMPPServer.hs | 15 +++++++++++----
 xmppServer.hs          | 18 ++++++++++++++++--
 2 files changed, 27 insertions(+), 6 deletions(-)

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index dd693b8c..af392f27 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -16,6 +16,7 @@ module XMPPServer
     , LangSpecificMessage(..)
     , peerKeyToText
     , peerKeyToResolvedName
+    , peerKeyToResolvedNames
     , addrToText
     , sendModifiedStanzaToPeer
     , sendModifiedStanzaToClient
@@ -50,6 +51,7 @@ import qualified Text.XML.Stream.Render as XML
 import qualified Text.XML.Stream.Parse as XML
 import Data.XML.Types as XML
 import Data.Maybe
+import Data.List (nub)
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
 import qualified Data.Text as Text (pack,unpack)
@@ -227,12 +229,17 @@ peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0"
 
 peerKeyToResolvedName :: ConnectionKey -> IO Text
 peerKeyToResolvedName k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1"
-peerKeyToResolvedName k@(PeerKey { callBackAddress=addr }) = do
-    mname <- handleIO_ (return Nothing) $ do
+peerKeyToResolvedName pk = do
+    ns <- peerKeyToResolvedNames pk
+    return $ maybe (peerKeyToText pk) id (listToMaybe ns)
+
+peerKeyToResolvedNames :: ConnectionKey -> IO [Text]
+peerKeyToResolvedNames k@(ClientKey { localAddress=addr }) = return []
+peerKeyToResolvedNames k@(PeerKey { callBackAddress=addr }) = do
+    handleIO_ (return []) $ 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 
+        return $ map Text.pack $ nub names
 
 
 wlog :: String -> IO ()
diff --git a/xmppServer.hs b/xmppServer.hs
index 8fdb4f78..107054bf 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -294,6 +294,7 @@ newConn state k addr outchan = do
 
 eofConn state k = atomically $ modifyTVar' (keyToChan state) $ Map.delete k
 
+{-
 rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr))
 rewriteJIDForClient1 jid = do
     let (n,h,r) = splitJID jid
@@ -301,6 +302,7 @@ rewriteJIDForClient1 jid = do
     flip (maybe $ return Nothing) maddr $ \addr -> do
         h' <- peerKeyToResolvedName (PeerKey addr)
         return $ Just ((n,h',r), addr)
+-}
 
 parseAddress :: Text -> IO (Maybe SockAddr)
 parseAddress addr_str = do
@@ -336,6 +338,17 @@ rewriteJIDForClient laddr jid = do
                   else peerKeyToResolvedName (PeerKey addr)
     return (mine,(n,h',r))
 
+multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
+multiplyJIDForClient laddr jid = do
+    let (n,h,r) = splitJID jid
+    maddr <- parseAddress (strip_brackets h)
+    flip (maybe $ return (False,[(n,ip6literal h,r)])) maddr $ \addr -> do
+    let mine =  laddr `withPort` 0  == addr `withPort` 0
+    names <- if mine then fmap (:[]) textHostName
+                     else peerKeyToResolvedNames (PeerKey addr)
+    return (mine,map (\h' -> (n,h',r)) names)
+
+
 addrTextToKey h = do
     maddr <- parseAddress (strip_brackets h)
     return (fmap PeerKey maddr)
@@ -460,9 +473,10 @@ informPeerPresence state k stanza = do
     forM_ clients $ \(ck,con,client) -> do
         from' <- do
             let ClientKey laddr = ck
-            (_,trip) <- rewriteJIDForClient laddr from
-            return (unsplitJID trip)
+            (_,trip) <- multiplyJIDForClient laddr from
+            return (map unsplitJID trip)
         putStrLn $ "sending to client: " ++ show (stanzaType stanza)
+        forM_ from' $ \from' -> do
         dup <- cloneStanza stanza
         sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
                                    (connChan con)
-- 
cgit v1.2.3