prefer roster-name to canonical name if possible.

1 files changed, 25 insertions, 13 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index f7f7fb36..babde683 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -9,7 +9,8 @@ import Control.Monad.Trans
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Network.Socket ( SockAddr(..) )
 import System.Endian (fromBE32)
-import Data.List (nub, (\\), intersect, groupBy, sort )
+import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
+import Data.Ord (comparing )
 import Data.Monoid ( (<>) )
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
@@ -351,18 +352,28 @@ withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
 -- came in on.  The returned JID parts are suitable for unsplitJID to create a
 -- valid JID for communicating to a client.  The returned Bool is True when the
 -- host part refers to this local host (i.e. it equals the given SockAddr).
-rewriteJIDForClient :: SockAddr -> Text -> IO (Bool,(Maybe Text,Text,Maybe Text))
-rewriteJIDForClient laddr jid = do
+-- If there are multiple results, it will prefer one which is a member of the
+-- given list in the last argument.
+rewriteJIDForClient :: SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
+rewriteJIDForClient laddr jid buds = 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
     h' <- if mine then textHostName
-                  else peerKeyToResolvedName (PeerKey addr)
+                  else peerKeyToResolvedName buds (PeerKey addr)
     return (mine,(n,h',r))
 
 sameAddress laddr addr = laddr `withPort` 0  == addr `withPort` 0
 
+peerKeyToResolvedName :: [Text] -> ConnectionKey -> IO Text
+peerKeyToResolvedName buds k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1"
+peerKeyToResolvedName buds pk = do
+    ns <- peerKeyToResolvedNames pk
+    let ns' = sortBy (comparing $ not . flip elem buds) ns
+    return $ maybe (peerKeyToText pk) id (listToMaybe ns')
+
+
 multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
 multiplyJIDForClient laddr jid = do
     let (n,h,r) = splitJID jid
@@ -427,16 +438,17 @@ deliverMessage state fail msg =
             $ \(Conn { connChan=sender_chan
                      , auxAddr=laddr }) -> do
         flip (maybe fail) (stanzaTo msg) $ \to -> do
-        (mine,(n,h,r)) <- rewriteJIDForClient laddr to
+        (mine,(n,h,r)) <- rewriteJIDForClient laddr to []
         if not mine then fail else do
         let to' = unsplitJID (n,h,r)
-        from' <- do
-            flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
-            (_,trip) <- rewriteJIDForClient laddr from
-            return . Just $ unsplitJID trip
         cmap <- atomically . readTVar $ clientsByUser state
         flip (maybe fail) n $ \n -> do
         flip (maybe fail) (Map.lookup n cmap) $ \presence_container -> do
+        buds <- configText ConfigFiles.getBuddies n
+        from' <- do
+            flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
+            (_,trip) <- rewriteJIDForClient laddr from [] -- XXX
+            return . Just $ unsplitJID trip
         let ks = Map.keys (networkClients presence_container)
             chans = mapMaybe (flip Map.lookup key_to_chan) ks
         if null chans then fail else do
@@ -767,9 +779,9 @@ peerSubscriptionRequest state fail k stanza chan = do
     ktc <- atomically . readTVar $ keyToChan state
     flip (maybe fail) (Map.lookup k ktc)
          $ \Conn { auxAddr=laddr } -> do
-    (mine,totup) <- rewriteJIDForClient laddr to
+    (mine,totup) <- rewriteJIDForClient laddr to []
     if not mine then fail else do
-    (_,fromtup) <- rewriteJIDForClient laddr from
+    (_,fromtup) <- rewriteJIDForClient laddr from []
     flip (maybe fail) mto_u $ \u -> do
     flip (maybe fail) mfrom_u $ \from_u -> do
     resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u
@@ -890,7 +902,7 @@ peerInformSubscription state fail k stanza = do
     flip (maybe fail) (Map.lookup k ktc)
         $ \(Conn { connChan=sender_chan
                  , auxAddr=laddr }) -> do
-    (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from
+    (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from []
     let from'' = unsplitJID (from_u,from_h,Nothing)
         muser = do
             to <- stanzaTo stanza
@@ -955,7 +967,7 @@ main = runResourceT $ do
         , xmppTellMyNameToClient = textHostName
         , xmppTellMyNameToPeer = \addr -> return $ addrToText addr
         , xmppTellPeerHisName = return . peerKeyToText
-        , xmppTellClientNameOfPeer = peerKeyToResolvedName
+        , xmppTellClientNameOfPeer = flip peerKeyToResolvedName
         , xmppNewConnection = newConn state
         , xmppEOF = eofConn state
         , xmppRosterBuddies = rosterGetBuddies state