From e6c64ef4e5fc0870aacff06b4903b4cfa8666478 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Fri, 6 Jul 2018 22:23:22 -0400
Subject: xmpp: Enable sending to lower-cased Tox peer without user field.

---
 Presence/Presence.hs | 29 ++++++++++++++++++++---------
 1 file changed, 20 insertions(+), 9 deletions(-)

(limited to 'Presence/Presence.hs')

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 59926d13..3dab724a 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -403,7 +403,7 @@ getSolicited' = configText ConfigFiles.getSolicited
 --
 --   * Text - Unix user who owns this roster entry.
 --
---   * Text - Profile, "." for xmpp, "<base64-key>.tox" for a tox-enabled client.
+--   * Text - Hostname as it appears in roster.
 --
 getBuddiesAndSolicited :: PresenceState
                          -> Text              -- ^ Config profile: "." or tox host.
@@ -423,7 +423,7 @@ getBuddiesAndSolicited state profile pred
                 fmap concat $ forM buds $ \(u,h,r) -> do
                 interested <- pred h
                 if interested
-                    then return [(isbud,u,user,profile)]
+                    then return [(isbud,u,user,h)]
                     else return []
 
 sendProbesAndSolicitations :: PresenceState -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
@@ -437,7 +437,7 @@ sendProbesAndSolicitations state k (Local laddr) chan = do
         h -> do
             addrs <- nub <$> resolvePeer h
             return $ k `elem` addrs -- Roster item resolves to /k/ peer.
-    forM_ xs $ \(isbud,u,user,profile) -> do
+    forM_ xs $ \(isbud,u,user,h) -> do
         let make = if isbud then presenceProbe
                             else presenceSolicitation
             toh = peerKeyToText k
@@ -598,13 +598,24 @@ deliverMessage state fail msg =
             return
               $ fromMaybe -- Resolve XMPP peer.
                           (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg))
-                $ do (mu,h,rsc) <- splitJID <$> stanzaTo msg
-                     u <- mu
+                $ do
                      client <- mclient
-                     (toxman,me,them) <- weAreTox state client h
-                     return -- Resolve Tox peer.
-                            $ do maddr <- resolveToxPeer toxman me them
-                                 return $ fmap (u,) maddr
+                     to <- stanzaTo msg
+                     let (mu,th,rsc) = splitJID to
+                     (toxman,me,_) <- weAreTox state client th
+                     return $ do
+                         -- In case the client sends us a lower-cased version of the base64
+                         -- tox key hostname, we resolve it by comparing it with roster entries.
+                         xs <- getBuddiesAndSolicited state (clientProfile client) $ \case
+                            rh | (_,".tox") <- Text.splitAt 43 rh
+                               , Text.toLower rh == Text.toLower th
+                               -> return True
+                            _ -> return False
+                         fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do
+                             let (them,_) = Text.splitAt 43 h
+                             maddr <- resolveToxPeer toxman me them
+                             let to' = unsplitJID (mu,h,rsc)
+                             return $ fmap (to',) maddr
         fromMaybe (do dput XJabber $ "Unable to resolve "++show (stanzaTo msg)
                       fail {- reverse lookup failure -})
                 $ mto <&> \(to',k) -> do
-- 
cgit v1.2.3