broadcast roster change to other clients on approve/reject

2 files changed, 31 insertions, 0 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 02dd5134..d9cacb4c 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -24,6 +24,7 @@ module XMPPServer
     , presenceSolicitation
     , makePresenceStanza
     , makeInformSubscription
+    , makeRosterUpdate
     , JabberShow(..)
     ) where
 
@@ -794,6 +795,20 @@ makePresenceStanza namespace mjid pstat = do
       , EventContent (ContentText stat)
       , EventEndElement "{jabber:client}show" ]
     
+makeRosterUpdate tojid contact relationship = do
+    let attrs = [attr "subscription" relationship]
+    stanzaFromList Unrecognized
+      [ EventBeginElement "{jabber:client}iq" 
+            [ attr "to"   tojid
+            , attr "id"   "someid"
+            , attr "type" "set"
+            ]
+      , EventBeginElement "{jabber:iq:roster}query" []
+      , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
+      , EventEndElement   "{jabber:iq:roster}item"
+      , EventEndElement   "{jabber:iq:roster}query"
+      , EventEndElement "{jabber:client}iq"
+      ]
 
 makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
 makePong namespace mid to from =
diff --git a/xmppServer.hs b/xmppServer.hs
index 13883c75..d10fe4c2 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -764,6 +764,22 @@ clientInformSubscription state fail k stanza = do
     -- send roster update to clients
     --  approve: both ( ∈ buddies) else from
     --  reject: to ( ∈ buddies ) else none 
+    (clients,ktc) <- atomically $ do
+        cbu <- readTVar (clientsByUser state)
+        let mlp = mu >>= flip Map.lookup cbu
+        let cs = maybe [] (Map.toList . networkClients) mlp
+        ktc <- readTVar (keyToChan state)
+        return (cs,ktc)
+
+    forM_ clients $ \(ck, client) -> do
+        when (clientIsInterested client) $ do
+        flip (maybe $ return ()) (Map.lookup ck ktc) $ \con -> do
+        hostname <- textHostName
+        -- TODO: Should cjid include the resource?
+        let cjid = unsplitJID (mu, hostname, Nothing)
+        update <- makeRosterUpdate cjid to relationship
+        sendModifiedStanzaToClient update (connChan con)
+
     
     -- notify peer
     return ()