Send whitelist= attribute on probe replies

1 files changed, 18 insertions, 6 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index fb056445..598ffe72 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -15,7 +15,7 @@ import Network.Socket
     , SockAddr(..)
     )
 import System.Endian (fromBE32)
-import Data.List (nub, (\\), intersect )
+import Data.List (nub, (\\), intersect, groupBy, sort )
 import Data.Monoid ( (<>) )
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
@@ -590,11 +590,20 @@ answerProbe state mto k chan = do
 
     flip (maybe $ return ()) muser $ \(u,conn,ch) -> do
 
-    -- only subscribed peers should get probe replies
-    addrs <- subscribedPeers u
+    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u
+    let gaddrs = groupBy (\a b -> snd a == snd b) (sort resolved_subs)
+        whitelist = do
+            xs <- gaddrs
+            x <- take 1 xs
+            guard $ snd x==k
+            mapMaybe fst xs
+
+    -- -- only subscribed peers should get probe replies
+    -- addrs <- subscribedPeers u
+
     -- TODO: notify remote peer that they are unsubscribed?
     --   reply <- makeInformSubscription "jabber:server" to from False
-    when (k `elem` map PeerKey addrs) $ do
+    when (not $ null whitelist) $ do
 
     replies <- runTraversableT $ do
         cbu <- lift . atomically $ readTVar (clientsByUser state)
@@ -605,7 +614,10 @@ answerProbe state mto k chan = do
         let jid = unsplitJID (Just $ clientUser clientState
                              , ch
                              ,Just $ clientResource clientState)
-        return stanza { stanzaFrom = Just jid }
+        return stanza { stanzaFrom = Just jid
+                      , stanzaType = (stanzaType stanza)
+                        { presenceWhiteList = whitelist }
+                      }
 
     forM_ replies $ \reply -> do
         sendModifiedStanzaToPeer reply chan
@@ -739,7 +751,7 @@ resolvedFromRoster doit u = do
     subs <- configText doit u
     runTraversableT $ do
             (mu,h,_) <- liftT $ splitJID `fmap` subs
-            addr <- liftMT $ resolvePeer h
+            addr <- liftMT $ fmap nub $ resolvePeer h
             return (mu,PeerKey addr)
 
 clientCons state ktc u = do