diff options
-rw-r--r-- | Presence/Presence.hs | 29 |
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 | -- |
408 | getBuddiesAndSolicited :: PresenceState | 408 | getBuddiesAndSolicited :: 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 | ||
429 | sendProbesAndSolicitations :: PresenceState -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO () | 429 | sendProbesAndSolicitations :: 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 |