diff options
-rw-r--r-- | xmppServer.hs | 63 |
1 files changed, 46 insertions, 17 deletions
diff --git a/xmppServer.hs b/xmppServer.hs index 9abf419d..74adc620 100644 --- a/xmppServer.hs +++ b/xmppServer.hs | |||
@@ -285,16 +285,19 @@ sendProbesAndSolicitations state k laddr chan = do | |||
285 | -- is a bad idea. Perhaps due to laziness and an | 285 | -- is a bad idea. Perhaps due to laziness and an |
286 | -- unforced list? Instead, we will return a list | 286 | -- unforced list? Instead, we will return a list |
287 | -- of (Bool,Text) for processing outside. | 287 | -- of (Bool,Text) for processing outside. |
288 | return (isbud,u) | 288 | return (isbud,u,if isbud then "" else user) |
289 | -- XXX: The following O(n²) nub may be a little | 289 | -- XXX: The following O(n²) nub may be a little |
290 | -- too onerous. | 290 | -- too onerous. |
291 | forM_ (nub xs) $ \(isbud,u) -> do | 291 | forM_ (nub xs) $ \(isbud,u,user) -> do |
292 | let make = if isbud then presenceProbe | 292 | let make = if isbud then presenceProbe |
293 | else presenceSolicitation | 293 | else presenceSolicitation |
294 | toh = peerKeyToText k | 294 | toh = peerKeyToText k |
295 | jid = unsplitJID (u,toh,Nothing) | 295 | jid = unsplitJID (u,toh,Nothing) |
296 | me = addrToText laddr | 296 | me = addrToText laddr |
297 | stanza <- make me jid | 297 | from = if isbud then me -- probe from server |
298 | else -- solicitation from particular user | ||
299 | unsplitJID (Just user,me,Nothing) | ||
300 | stanza <- make from jid | ||
298 | -- send probes for buddies, solicitations for solicited. | 301 | -- send probes for buddies, solicitations for solicited. |
299 | putStrLn $ "probing "++show k++" for: " ++ show (isbud,jid) | 302 | putStrLn $ "probing "++show k++" for: " ++ show (isbud,jid) |
300 | atomically $ writeTChan chan stanza | 303 | atomically $ writeTChan chan stanza |
@@ -475,6 +478,7 @@ subscribedPeers user = do | |||
475 | let hosts = map ((\(_,h,_)->h) . splitJID) jids | 478 | let hosts = map ((\(_,h,_)->h) . splitJID) jids |
476 | fmap Map.keys $ resolveAllPeers hosts | 479 | fmap Map.keys $ resolveAllPeers hosts |
477 | 480 | ||
481 | -- | this JID is suitable for peers, not clients. | ||
478 | clientJID con client = unsplitJID ( Just $ clientUser client | 482 | clientJID con client = unsplitJID ( Just $ clientUser client |
479 | , addrToText $ auxAddr con | 483 | , addrToText $ auxAddr con |
480 | , Just $ clientResource client) | 484 | , Just $ clientResource client) |
@@ -600,6 +604,9 @@ sendCachedPresence state k = do | |||
600 | addrs <- resolveAllPeers hosts | 604 | addrs <- resolveAllPeers hosts |
601 | let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs | 605 | let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs |
602 | ClientKey laddr = k | 606 | ClientKey laddr = k |
607 | mcon <- atomically $ do ktc <- readTVar (keyToChan state) | ||
608 | return $ Map.lookup k ktc | ||
609 | flip (maybe $ return ()) mcon $ \con -> do | ||
603 | forM_ (Map.toList onlines) $ \(pk, umap) -> do | 610 | forM_ (Map.toList onlines) $ \(pk, umap) -> do |
604 | forM_ (Map.toList umap) $ \(user,rp) -> do | 611 | forM_ (Map.toList umap) $ \(user,rp) -> do |
605 | let h = peerKeyToText pk | 612 | let h = peerKeyToText pk |
@@ -609,12 +616,18 @@ sendCachedPresence state k = do | |||
609 | forM_ js $ \jid -> do | 616 | forM_ js $ \jid -> do |
610 | let from' = unsplitJID jid | 617 | let from' = unsplitJID jid |
611 | dup <- cloneStanza stanza | 618 | dup <- cloneStanza stanza |
612 | mcon <- atomically $ do ktc <- readTVar (keyToChan state) | ||
613 | return $ Map.lookup k ktc | ||
614 | flip (maybe $ return ()) mcon $ \con -> do | ||
615 | sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) | 619 | sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) |
616 | (connChan con) | 620 | (connChan con) |
617 | 621 | ||
622 | pending <- configText ConfigFiles.getPending (clientUser client) | ||
623 | hostname <- textHostName | ||
624 | forM_ pending $ \pending_jid -> do | ||
625 | let cjid = unsplitJID ( Just $ clientUser client | ||
626 | , hostname | ||
627 | , Nothing ) | ||
628 | ask <- presenceSolicitation pending_jid cjid | ||
629 | sendModifiedStanzaToClient ask (connChan con) | ||
630 | |||
618 | -- Note: relying on self peer connection to send | 631 | -- Note: relying on self peer connection to send |
619 | -- send local buddies. | 632 | -- send local buddies. |
620 | return () | 633 | return () |
@@ -657,13 +670,16 @@ clientSubscriptionRequest state fail k stanza chan = do | |||
657 | liftM2 (,) (readTVar $ keyToChan state) | 670 | liftM2 (,) (readTVar $ keyToChan state) |
658 | (readTVar $ associatedPeers state) | 671 | (readTVar $ associatedPeers state) |
659 | 672 | ||
660 | hostname <- textHostName | 673 | case stanzaType stanza of |
661 | let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing) | 674 | PresenceRequestSubscription True -> do |
662 | chans <- clientCons state ktc (clientUser client) | 675 | hostname <- textHostName |
663 | forM_ chans $ \( Conn { connChan=chan }, client ) -> do | 676 | let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing) |
664 | -- roster update ask="subscribe" | 677 | chans <- clientCons state ktc (clientUser client) |
665 | update <- makeRosterUpdate cjid to ("ask","subscribe") | 678 | forM_ chans $ \( Conn { connChan=chan }, client ) -> do |
666 | sendModifiedStanzaToClient update chan | 679 | -- roster update ask="subscribe" |
680 | update <- makeRosterUpdate cjid to ("ask","subscribe") | ||
681 | sendModifiedStanzaToClient update chan | ||
682 | _ -> return () | ||
667 | 683 | ||
668 | let dsts = Map.fromList $ map ((,()) . PeerKey) addrs | 684 | let dsts = Map.fromList $ map ((,()) . PeerKey) addrs |
669 | cdsts = ktc `Map.intersection` dsts | 685 | cdsts = ktc `Map.intersection` dsts |
@@ -726,15 +742,18 @@ peerSubscriptionRequest state fail k stanza chan = do | |||
726 | flip (maybe fail) mfrom_u $ \from_u -> do | 742 | flip (maybe fail) mfrom_u $ \from_u -> do |
727 | resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u | 743 | resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u |
728 | let already_subscribed = elem (mfrom_u,k) resolved_subs | 744 | let already_subscribed = elem (mfrom_u,k) resolved_subs |
745 | is_wanted = case stanzaType stanza of | ||
746 | PresenceRequestSubscription b -> b | ||
747 | _ -> False -- Shouldn't happen. | ||
729 | -- Section 8 says (for presence of type "subscribe", the server MUST | 748 | -- Section 8 says (for presence of type "subscribe", the server MUST |
730 | -- adhere to the rules defined under Section 3 and summarized under | 749 | -- adhere to the rules defined under Section 3 and summarized under |
731 | -- see Appendix A. (pariticularly Appendex A.3.1) | 750 | -- see Appendix A. (pariticularly Appendex A.3.1) |
732 | if already_subscribed | 751 | if already_subscribed == is_wanted |
733 | then do | 752 | then do |
734 | -- contact ∈ subscribers --> SHOULD NOT, already handled | 753 | -- contact ∈ subscribers --> SHOULD NOT, already handled |
735 | -- already subscribed, reply and quit | 754 | -- already subscribed, reply and quit |
736 | -- (note: swapping to and from for reply) | 755 | -- (note: swapping to and from for reply) |
737 | reply <- makeInformSubscription "jabber:server" to from True | 756 | reply <- makeInformSubscription "jabber:server" to from is_wanted |
738 | sendModifiedStanzaToPeer reply chan | 757 | sendModifiedStanzaToPeer reply chan |
739 | else do | 758 | else do |
740 | 759 | ||
@@ -744,7 +763,17 @@ peerSubscriptionRequest state fail k stanza chan = do | |||
744 | handle (\e -> let _ = isDoesNotExistError e in fail) $ do | 763 | handle (\e -> let _ = isDoesNotExistError e in fail) $ do |
745 | -- add from-address to to's pending | 764 | -- add from-address to to's pending |
746 | addrs <- resolvePeer from_h | 765 | addrs <- resolvePeer from_h |
747 | already_pending <- addToRosterFile ConfigFiles.modifyPending u from addrs | 766 | |
767 | let from' = unsplitJID fromtup | ||
768 | |||
769 | already_pending <- | ||
770 | if is_wanted then | ||
771 | addToRosterFile ConfigFiles.modifyPending u from' addrs | ||
772 | else do | ||
773 | removeFromRosterFile ConfigFiles.modifySubscribers u from' addrs | ||
774 | reply <- makeInformSubscription "jabber:server" to from is_wanted | ||
775 | sendModifiedStanzaToPeer reply chan | ||
776 | return False | ||
748 | 777 | ||
749 | -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT | 778 | -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT |
750 | when (not already_pending) $ do | 779 | when (not already_pending) $ do |
@@ -755,7 +784,7 @@ peerSubscriptionRequest state fail k stanza chan = do | |||
755 | -- send to clients | 784 | -- send to clients |
756 | -- TODO: interested/available clients only? | 785 | -- TODO: interested/available clients only? |
757 | dup <- cloneStanza stanza | 786 | dup <- cloneStanza stanza |
758 | sendModifiedStanzaToClient dup { stanzaFrom = Just $ unsplitJID fromtup | 787 | sendModifiedStanzaToClient dup { stanzaFrom = Just $ from' |
759 | , stanzaTo = Just $ unsplitJID totup } | 788 | , stanzaTo = Just $ unsplitJID totup } |
760 | chan | 789 | chan |
761 | 790 | ||