Comments documenting home-grown <presence> whitelist attribute.

2 files changed, 22 insertions, 1 deletions

diff --git a/Presence/Stanza/Types.hs b/Presence/Stanza/Types.hs
index cbb156a0..3e039a34 100644
--- a/Presence/Stanza/Types.hs
+++ b/Presence/Stanza/Types.hs
@@ -50,7 +50,20 @@ data StanzaType
                      , presencePriority :: Maybe Int8
                      , presenceStatus :: [(Lang,Text)]
                      , presenceWhiteList :: [Text]
+                        -- ^ A custom extension extension we are using.  When a
+                        -- peer answers a presence probe, it also communicates
+                        -- to the remote peer which remote users it believes
+                        -- are subscribed to that presence.
+                        --
+                        -- This is communicated via a space-delimited list in
+                        -- the nonstandard "whitelist" attribute for a
+                        -- <{jabber:server}presence> tag.
+                        --
+                        -- TODO: Use this to update the buddies file so that a
+                        -- client is made aware when a subscription was
+                        -- canceled.
                      }
+
     | PresenceInformError
     | PresenceInformSubscription Bool
     | PresenceRequestStatus
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 218e60e0..a0d5a69b 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -305,6 +305,12 @@ swapit old new (EventEndElement n) | nameNamespace n==Just old =
     EventEndElement (n { nameNamespace = Just new })
 swapit old new x = x
 
+-- | This is invoked by sendModifiedStanzaTo* before swapping the namespace.
+--
+-- Optionally, when the namespace is jabber:server, this will set a "whitelist"
+-- attribute on a presence tag that indicates a list of users deliminated by
+-- spaces.  This is so that a server can communicate to another server which
+-- users are believed to be subscribed.
 fixHeaders :: Monad m => Stanza -> ConduitM Event Event m ()
 fixHeaders Stanza { stanzaType=typ, stanzaTo=mto, stanzaFrom=mfrom } = do
     x <- await
@@ -319,8 +325,10 @@ fixHeaders Stanza { stanzaType=typ, stanzaTo=mto, stanzaFrom=mfrom } = do
         as'' = maybe as' (setAttrib "from" as') mfrom
         as3 = case typ of
                 PresenceStatus {} | nameNamespace n == Just "jabber:client"
-                  -> delAttrib "whitelist" as''
+                  -> delAttrib "whitelist" as'' -- client-to-peer "whitelist" is filtered.
                 PresenceStatus {} | otherwise
+                  -- peer-to-client, we may have set a list of subscribed users
+                  -- to be communicated to the remote end.
                   -> case presenceWhiteList typ of
                         [] -> delAttrib "whitelist" as''
                         ws -> setAttrib "whitelist" as'' (Text.intercalate " " ws)