From 17d5d5dcb575ddf9e951c4ea027530bf910c8e0d Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 9 Mar 2014 13:10:50 -0400 Subject: roster work --- xmppServer.hs | 63 +++++++++++++++++++++++++++++++++++++++++++---------------- 1 file 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 -- 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) + return (isbud,u,if isbud then "" else user) -- XXX: The following O(nĀ²) nub may be a little -- too onerous. - forM_ (nub xs) $ \(isbud,u) -> do + forM_ (nub xs) $ \(isbud,u,user) -> do let make = if isbud then presenceProbe else presenceSolicitation toh = peerKeyToText k jid = unsplitJID (u,toh,Nothing) me = addrToText laddr - stanza <- make me jid + from = if isbud then me -- probe from server + else -- solicitation from particular user + unsplitJID (Just user,me,Nothing) + stanza <- make from jid -- send probes for buddies, solicitations for solicited. putStrLn $ "probing "++show k++" for: " ++ show (isbud,jid) atomically $ writeTChan chan stanza @@ -475,6 +478,7 @@ subscribedPeers user = do let hosts = map ((\(_,h,_)->h) . splitJID) jids fmap Map.keys $ resolveAllPeers hosts +-- | this JID is suitable for peers, not clients. clientJID con client = unsplitJID ( Just $ clientUser client , addrToText $ auxAddr con , Just $ clientResource client) @@ -600,6 +604,9 @@ sendCachedPresence state k = do addrs <- resolveAllPeers hosts let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs ClientKey laddr = k + mcon <- atomically $ do ktc <- readTVar (keyToChan state) + return $ Map.lookup k ktc + flip (maybe $ return ()) mcon $ \con -> do forM_ (Map.toList onlines) $ \(pk, umap) -> do forM_ (Map.toList umap) $ \(user,rp) -> do let h = peerKeyToText pk @@ -609,12 +616,18 @@ sendCachedPresence state k = do forM_ js $ \jid -> do let from' = unsplitJID jid dup <- cloneStanza stanza - mcon <- atomically $ do ktc <- readTVar (keyToChan state) - return $ Map.lookup k ktc - flip (maybe $ return ()) mcon $ \con -> do sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) (connChan con) + pending <- configText ConfigFiles.getPending (clientUser client) + hostname <- textHostName + forM_ pending $ \pending_jid -> do + let cjid = unsplitJID ( Just $ clientUser client + , hostname + , Nothing ) + ask <- presenceSolicitation pending_jid cjid + sendModifiedStanzaToClient ask (connChan con) + -- Note: relying on self peer connection to send -- send local buddies. return () @@ -657,13 +670,16 @@ clientSubscriptionRequest state fail k stanza chan = do liftM2 (,) (readTVar $ keyToChan state) (readTVar $ associatedPeers state) - hostname <- textHostName - let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing) - chans <- clientCons state ktc (clientUser client) - forM_ chans $ \( Conn { connChan=chan }, client ) -> do - -- roster update ask="subscribe" - update <- makeRosterUpdate cjid to ("ask","subscribe") - sendModifiedStanzaToClient update chan + case stanzaType stanza of + PresenceRequestSubscription True -> do + hostname <- textHostName + let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing) + chans <- clientCons state ktc (clientUser client) + forM_ chans $ \( Conn { connChan=chan }, client ) -> do + -- roster update ask="subscribe" + update <- makeRosterUpdate cjid to ("ask","subscribe") + sendModifiedStanzaToClient update chan + _ -> return () let dsts = Map.fromList $ map ((,()) . PeerKey) addrs cdsts = ktc `Map.intersection` dsts @@ -726,15 +742,18 @@ peerSubscriptionRequest state fail k stanza chan = do flip (maybe fail) mfrom_u $ \from_u -> do resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u let already_subscribed = elem (mfrom_u,k) resolved_subs + is_wanted = case stanzaType stanza of + PresenceRequestSubscription b -> b + _ -> False -- Shouldn't happen. -- Section 8 says (for presence of type "subscribe", the server MUST -- adhere to the rules defined under Section 3 and summarized under -- see Appendix A. (pariticularly Appendex A.3.1) - if already_subscribed + if already_subscribed == is_wanted then do -- contact āˆˆ subscribers --> SHOULD NOT, already handled -- already subscribed, reply and quit -- (note: swapping to and from for reply) - reply <- makeInformSubscription "jabber:server" to from True + reply <- makeInformSubscription "jabber:server" to from is_wanted sendModifiedStanzaToPeer reply chan else do @@ -744,7 +763,17 @@ peerSubscriptionRequest state fail k stanza chan = do handle (\e -> let _ = isDoesNotExistError e in fail) $ do -- add from-address to to's pending addrs <- resolvePeer from_h - already_pending <- addToRosterFile ConfigFiles.modifyPending u from addrs + + let from' = unsplitJID fromtup + + already_pending <- + if is_wanted then + addToRosterFile ConfigFiles.modifyPending u from' addrs + else do + removeFromRosterFile ConfigFiles.modifySubscribers u from' addrs + reply <- makeInformSubscription "jabber:server" to from is_wanted + sendModifiedStanzaToPeer reply chan + return False -- contact āˆ‰ subscribers & contact āˆˆ pending --> SHOULD NOT when (not already_pending) $ do @@ -755,7 +784,7 @@ peerSubscriptionRequest state fail k stanza chan = do -- send to clients -- TODO: interested/available clients only? dup <- cloneStanza stanza - sendModifiedStanzaToClient dup { stanzaFrom = Just $ unsplitJID fromtup + sendModifiedStanzaToClient dup { stanzaFrom = Just $ from' , stanzaTo = Just $ unsplitJID totup } chan -- cgit v1.2.3