roster work

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
         -- 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