2 files changed, 29 insertions, 25 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 9059a4c0..efd865d8 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -16,8 +16,6 @@ module XMPPServer
     , cloneStanza
     , LangSpecificMessage(..)
     , peerKeyToText
-    , peerKeyToResolvedName
-    , peerKeyToResolvedNames
     , addrToText
     , sendModifiedStanzaToPeer
     , sendModifiedStanzaToClient
@@ -185,7 +183,7 @@ data XMPPServerParameters =
     , xmppRosterOthers       :: ConnectionKey -> IO [Text]
     , xmppSubscribeToRoster :: ConnectionKey -> IO ()
     -- , xmppLookupClientJID :: ConnectionKey -> IO Text
-    , xmppTellClientNameOfPeer :: ConnectionKey -> IO Text
+    , xmppTellClientNameOfPeer :: ConnectionKey -> [Text] -> IO Text
     , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
     , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
     , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO ()
@@ -240,12 +238,6 @@ peerKeyToText :: ConnectionKey -> Text
 peerKeyToText (PeerKey { callBackAddress=addr }) = addrToText addr
 peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0"
 
-peerKeyToResolvedName :: ConnectionKey -> IO Text
-peerKeyToResolvedName k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1"
-peerKeyToResolvedName pk = do
-    ns <- peerKeyToResolvedNames pk
-    return $ maybe (peerKeyToText pk) id (listToMaybe ns)
-
 
 wlog :: String -> IO ()
 wlog s = putStrLn s >> hFlush stdout
@@ -1343,9 +1335,6 @@ sendRoster query xmpp replyto = do
              NetworkOrigin k _ -> Just k
              LocalPeer -> Nothing -- local peer requested roster?
     flip (maybe $ return ()) k $ \k -> do
-    jid <- case k of
-                ClientKey {} -> xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
-                PeerKey {}   -> xmppTellClientNameOfPeer xmpp k
     hostname <- xmppTellMyNameToClient xmpp
     let getlist f = do
             bs <- f xmpp k
@@ -1354,6 +1343,9 @@ sendRoster query xmpp replyto = do
     subscribers <- getlist xmppRosterSubscribers
     solicited   <- getlist xmppRosterSolicited
     subnone0    <- getlist xmppRosterOthers
+    jid <- case k of
+                ClientKey {} -> xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
+                PeerKey {}   -> xmppTellClientNameOfPeer xmpp k (Set.toList buddies)
     let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers
     let subto = buddies \\ subscribers
     let subfrom = subscribers \\ buddies
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