peerSubscriptionRequest

2 files changed, 38 insertions, 6 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index a61601ef..02dd5134 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -23,6 +23,7 @@ module XMPPServer
     , presenceProbe
     , presenceSolicitation
     , makePresenceStanza
+    , makeInformSubscription
     , JabberShow(..)
     ) where
 
@@ -759,6 +760,15 @@ grokStanza "jabber:client" stanzaTag =
 mkname :: Text -> Text -> XML.Name
 mkname namespace name = (Name name (Just namespace) Nothing)
 
+makeInformSubscription namespace from to approved = 
+    stanzaFromList (PresenceInformSubscription approved)
+      $ [ EventBeginElement (mkname namespace "presence")
+            [ attr "from" from
+            , attr "to" to
+            , attr "type" $ if approved then "subscribed"
+                                        else "unsubscribed" ]
+        , EventEndElement (mkname namespace "presence")]
+
 makePresenceStanza namespace mjid pstat = do
     stanzaFromList PresenceStatus { presenceShow = pstat
                                   , presencePriority = Nothing
diff --git a/xmppServer.hs b/xmppServer.hs
index 81cbf212..c781baf9 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -528,8 +528,8 @@ informPeerPresence state k stanza = do
         writeTVar (remotesByPeer state) $ Map.insert k umap' rbp
         -- TODO: Store or delete the stanza (remotesByPeer)
         
-        -- For now, all clients:
-        -- (TODO: interested/auteorized clients only.)
+        -- all clients, we'll filter available/authorized later
+
         ktc <- readTVar (keyToChan state)
         runTraversableT $ do
         (ck,client) <- liftMT $ fmap Map.toList $ readTVar (clients state)
@@ -537,6 +537,8 @@ informPeerPresence state k stanza = do
         return (ck,con,client)
     putStrLn $ "xmppInformPeerPresence (length clients="++show (length clients)++")"
     forM_ clients $ \(ck,con,client) -> do
+        -- (TODO: appropriately authorized clients only.)
+        -- For now, all "available" clients (available = sent initial presence)
         when (clientIsAvailable client) $ do
         froms <- do
             let ClientKey laddr = ck
@@ -667,6 +669,12 @@ peerSubscriptionRequest state fail k stanza chan = do
         (mfrom_u,from_h,_) = splitJID from
     to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource
     from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource
+    ktc <- atomically . readTVar $ keyToChan state
+    flip (maybe fail) (Map.lookup k ktc)
+         $ \Conn { auxAddr=laddr } -> do
+    (mine,totup) <- rewriteJIDForClient laddr to
+    if not mine then fail else do
+    (_,fromtup) <- rewriteJIDForClient laddr from
     flip (maybe fail) mto_u $ \u -> do
     flip (maybe fail) mfrom_u $ \from_u -> do
     subs <- configText ConfigFiles.getSubscribers u
@@ -681,8 +689,10 @@ peerSubscriptionRequest state fail k stanza chan = do
     if already_subscribed
      then do
         -- contact ∈ subscribers --> SHOULD NOT, already handled
-        -- TODO: already subscribed, reply and quit
-        return ()
+        -- already subscribed, reply and quit
+        -- (note: swapping to and from for reply)
+        reply <- makeInformSubscription "jabber:server" to from True
+        sendModifiedStanzaToPeer reply chan
      else do
     -- Catch exception in case the user does not exist
     handle (\e -> let _ = isDoesNotExistError e in fail) $ do
@@ -693,8 +703,20 @@ peerSubscriptionRequest state fail k stanza chan = do
     -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
     when (not already_pending) $ do
     -- contact ∉ subscribers & contact ∉ pending --> MUST
-    -- TODO: send to clients
-    return ()
+    mlp <- atomically $ do
+            cmap <- readTVar $ clientsByUser state
+            return $ Map.lookup u cmap
+    let ks = do lp <- maybeToList mlp
+                Map.keys (networkClients lp)
+        chans = mapMaybe (flip Map.lookup ktc) ks
+    forM_ chans $ \Conn { connChan=chan } -> do
+    -- send to clients
+    -- TODO: interested/available clients only?
+    dup <- cloneStanza stanza
+    sendModifiedStanzaToClient dup { stanzaFrom = Just $ unsplitJID fromtup
+                                   , stanzaTo = Just $ unsplitJID totup }
+                               chan
+
 
 clientInformSubscription state fail k stanza = do
     putStrLn $ "TODO: clientInformSubscription"