From 5b6f895c3b2bda2b46e8241a91476073308fc4cf Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Thu, 21 Jun 2018 19:23:08 -0400
Subject: Send outgoing friend requests from XMPP clients.

---
 Presence/Presence.hs | 46 ++++++++++++++++++++++++++++++++++++----------
 1 file changed, 36 insertions(+), 10 deletions(-)

(limited to 'Presence/Presence.hs')

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index a33de0a6..a55d49ab 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -384,11 +384,26 @@ getBuddies' = configText ConfigFiles.getBuddies
 getSolicited' :: Text -> Text -> IO [Text]
 getSolicited' = configText ConfigFiles.getSolicited
 
-sendProbesAndSolicitations :: PresenceState
-                            -> ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
-sendProbesAndSolicitations state k laddr chan = do
-    -- get all buddies & solicited matching k for all users
-    xs <- runTraversableT $ do
+-- | Obtain from roster all buddies and pending buddies (called solicited
+-- regardless of whether we've yet delivered a friend-request) matching the
+-- supplied side-effecting predicate.
+--
+-- Returned tuple:
+--
+--   * Bool - True if buddy (should send probe).
+--            False if solicited (should send friend-request).
+--
+--   * Maybe Username - Username field of contact.
+--
+--   * Text - Unix user who owns this roster entry.
+--
+--   * Text - Profile, "." for xmpp, "tox" for a tox-enabled client.
+--
+getBuddiesAndSolicited :: PresenceState -> (Text -> IO Bool) -> IO [(Bool, Maybe UserName, Text, Text)]
+getBuddiesAndSolicited state 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
@@ -396,17 +411,28 @@ sendProbesAndSolicitations state k laddr chan = do
                                 ,(False,getSolicited')]
         bud  <- liftMT $ getter user profile
         let (u,h,r) = splitJID bud
-        addr <- liftMT $ nub `fmap` resolvePeer h
-        liftT $ guard (PeerKey addr == k)
+        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)
-    -- XXX: The following O(n²) nub may be a little
-    --      too onerous.
-    forM_ (nub xs) $ \(isbud,u,user,profile) -> do
+
+sendProbesAndSolicitations :: PresenceState
+                            -> ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
+sendProbesAndSolicitations state k laddr chan = do
+    -- get all buddies & solicited matching k for all users
+    xs <- getBuddiesAndSolicited state $ \case
+        h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module.
+        h -> do
+            addrs <- nub `fmap` resolvePeer h
+            case k of
+                ClientKey _ -> return False            -- Solicitations and probes are only for peers.
+                PeerKey a   -> return $ a `elem` addrs -- Only for this peer /k/.
+    forM_ xs $ \(isbud,u,user,profile) -> do
         let make = if isbud then presenceProbe
                             else presenceSolicitation
             toh = peerKeyToText k
-- 
cgit v1.2.3