ToxToXMPP: Check solicited only for the correct secret key.

1 files changed, 24 insertions, 22 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index befe47e1..5fe4e8cf 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -394,36 +394,38 @@ getSolicited' = configText ConfigFiles.getSolicited
 --
 --   * Text - Profile, "." for xmpp, "tox" for a tox-enabled client.
 --
-getBuddiesAndSolicited :: PresenceState -> (Text -> IO Bool) -> IO [(Bool, Maybe UserName, Text, Text)]
-getBuddiesAndSolicited state pred
+getBuddiesAndSolicited :: PresenceState
+                         -> Text              -- ^ Config profile: "." or tox host.
+                         -> (Text -> IO Bool) -- ^ Return True if you want this hostname.
+                         -> IO [(Bool, Maybe UserName, Text, Text)]
+getBuddiesAndSolicited state profile pred
     -- XXX: The following O(n²) nub may be a little
     --      too onerous.
-    = fmap nub $ runTraversableT $ do
-        cbu <- lift $ atomically $ readTVar $ clientsByUser state
-        (user,LocalPresence cmap) <- liftT $ Map.toList cbu
-        profile <- liftT $ nub $ map clientProfile $ Map.elems cmap
-        (isbud,getter) <- liftT [(True ,getBuddies'  )
-                                ,(False,getSolicited')]
-        bud  <- liftMT $ getter user profile
-        let (u,h,r) = splitJID bud
-        interested <- lift $ pred h
-        guard interested
-
-        -- Note: Earlier I was tempted to do all the IO
-        -- within the TraversableT monad.  That apparently
-        -- is a bad idea.  Perhaps due to laziness and an
-        -- unforced list?  Instead, we will return a list
-        -- of (Bool,Text) for processing outside.
-        return (isbud,u,user,profile)
+    = fmap nub $ do
+        cbu <- atomically $ readTVar $ clientsByUser state
+        fmap concat $ sequence $ do
+            (user,LocalPresence cmap) <- Map.toList cbu
+            (isbud, getter) <- [(True ,getBuddies'  )
+                               ,(False,getSolicited')]
+            return $ do
+                buds <- map splitJID <$> getter user profile
+                fmap concat $ forM buds $ \(u,h,r) -> do
+                interested <- pred h
+                if interested
+                    then return [(isbud,u,user,profile)]
+                    else return []
 
 sendProbesAndSolicitations :: PresenceState -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
 sendProbesAndSolicitations state k (Local laddr) chan = do
+    prof <- atomically $ do
+        pktc <- readTVar (pkeyToChan state)
+        return $ maybe "." (cdProfile . auxData) $  Map.lookup k pktc
     -- get all buddies & solicited matching k for all users
-    xs <- getBuddiesAndSolicited state $ \case
+    xs <- getBuddiesAndSolicited state prof $ \case
         h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module.
         h -> do
-            addrs <- nub `fmap` resolvePeer h
-            return $ k `elem` addrs -- Only for this peer /k/.
+            addrs <- nub <$> resolvePeer h
+            return $ k `elem` addrs -- Roster item resolves to /k/ peer.
     forM_ xs $ \(isbud,u,user,profile) -> do
         let make = if isbud then presenceProbe
                             else presenceSolicitation