summaryrefslogtreecommitdiff
path: root/Presence/Presence.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/Presence.hs')
-rw-r--r--Presence/Presence.hs29
1 files changed, 20 insertions, 9 deletions
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
403-- 403--
404-- * Text - Unix user who owns this roster entry. 404-- * Text - Unix user who owns this roster entry.
405-- 405--
406-- * Text - Profile, "." for xmpp, "<base64-key>.tox" for a tox-enabled client. 406-- * Text - Hostname as it appears in roster.
407-- 407--
408getBuddiesAndSolicited :: PresenceState 408getBuddiesAndSolicited :: PresenceState
409 -> Text -- ^ Config profile: "." or tox host. 409 -> Text -- ^ Config profile: "." or tox host.
@@ -423,7 +423,7 @@ getBuddiesAndSolicited state profile pred
423 fmap concat $ forM buds $ \(u,h,r) -> do 423 fmap concat $ forM buds $ \(u,h,r) -> do
424 interested <- pred h 424 interested <- pred h
425 if interested 425 if interested
426 then return [(isbud,u,user,profile)] 426 then return [(isbud,u,user,h)]
427 else return [] 427 else return []
428 428
429sendProbesAndSolicitations :: PresenceState -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO () 429sendProbesAndSolicitations :: PresenceState -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
@@ -437,7 +437,7 @@ sendProbesAndSolicitations state k (Local laddr) chan = do
437 h -> do 437 h -> do
438 addrs <- nub <$> resolvePeer h 438 addrs <- nub <$> resolvePeer h
439 return $ k `elem` addrs -- Roster item resolves to /k/ peer. 439 return $ k `elem` addrs -- Roster item resolves to /k/ peer.
440 forM_ xs $ \(isbud,u,user,profile) -> do 440 forM_ xs $ \(isbud,u,user,h) -> do
441 let make = if isbud then presenceProbe 441 let make = if isbud then presenceProbe
442 else presenceSolicitation 442 else presenceSolicitation
443 toh = peerKeyToText k 443 toh = peerKeyToText k
@@ -598,13 +598,24 @@ deliverMessage state fail msg =
598 return 598 return
599 $ fromMaybe -- Resolve XMPP peer. 599 $ fromMaybe -- Resolve XMPP peer.
600 (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg)) 600 (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg))
601 $ do (mu,h,rsc) <- splitJID <$> stanzaTo msg 601 $ do
602 u <- mu
603 client <- mclient 602 client <- mclient
604 (toxman,me,them) <- weAreTox state client h 603 to <- stanzaTo msg
605 return -- Resolve Tox peer. 604 let (mu,th,rsc) = splitJID to
606 $ do maddr <- resolveToxPeer toxman me them 605 (toxman,me,_) <- weAreTox state client th
607 return $ fmap (u,) maddr 606 return $ do
607 -- In case the client sends us a lower-cased version of the base64
608 -- tox key hostname, we resolve it by comparing it with roster entries.
609 xs <- getBuddiesAndSolicited state (clientProfile client) $ \case
610 rh | (_,".tox") <- Text.splitAt 43 rh
611 , Text.toLower rh == Text.toLower th
612 -> return True
613 _ -> return False
614 fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do
615 let (them,_) = Text.splitAt 43 h
616 maddr <- resolveToxPeer toxman me them
617 let to' = unsplitJID (mu,h,rsc)
618 return $ fmap (to',) maddr
608 fromMaybe (do dput XJabber $ "Unable to resolve "++show (stanzaTo msg) 619 fromMaybe (do dput XJabber $ "Unable to resolve "++show (stanzaTo msg)
609 fail {- reverse lookup failure -}) 620 fail {- reverse lookup failure -})
610 $ mto <&> \(to',k) -> do 621 $ mto <&> \(to',k) -> do