Allow whitelist= attribute on jabber:server presence status

1 files changed, 28 insertions, 11 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 6f117204..aae5e97a 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -59,7 +59,7 @@ import Data.Maybe
 import Data.List (nub)
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
-import qualified Data.Text as Text (pack,unpack)
+import qualified Data.Text as Text (pack,unpack,words,intercalate)
 import Data.Char (toUpper,chr,ord)
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -144,6 +144,7 @@ data StanzaType
     | PresenceStatus { presenceShow :: JabberShow
                      , presencePriority :: Maybe Int8
                      , presenceStatus :: [(Lang,Text)]
+                     , presenceWhiteList :: [Text]
                      }
     | PresenceInformError
     | PresenceInformSubscription Bool
@@ -334,18 +335,29 @@ swapit old new (EventEndElement n) | nameNamespace n==Just old =
 swapit old new x = x
 
 fixHeaders :: Monad m => Stanza -> ConduitM Event Event m ()
-fixHeaders Stanza { stanzaTo=mto, stanzaFrom=mfrom } = do
+fixHeaders Stanza { stanzaType=typ, stanzaTo=mto, stanzaFrom=mfrom } = do
     x <- await
     maybe (return ()) f x
  where
-    f (EventBeginElement n as) = do yield $ EventBeginElement n (update as)
+    f (EventBeginElement n as) = do yield $ EventBeginElement n (update n as)
                                     awaitForever yield
     f x = yield x >> awaitForever yield
-    update as = as''
+    update n as = as3
      where
-        as' = maybe as (\to->attr "to" to:as) mto
-        as'' = maybe as' (\from->attr "from" from:as') mfrom
-    
+        as' = maybe as (setAttrib "to" as) mto
+        as'' = maybe as' (setAttrib "from" as') mfrom
+        as3 = case typ of
+                PresenceStatus {} | nameNamespace n == Just "jabber:client"
+                  -> delAttrib "whitelist" as''
+                PresenceStatus {} | otherwise
+                  -> case presenceWhiteList typ of
+                        [] -> delAttrib "whitelist" as''
+                        ws -> setAttrib "whitelist" as'' (Text.intercalate " " ws)
+                _ -> as''
+
+        setAttrib akey as aval = attr akey aval:filter ((/=akey) . fst) as
+        delAttrib akey as = filter ((/=akey) . fst) as
+
 conduitToChan
   :: Conduit () IO Event
      -> IO (LockedChan Event, TVar (Maybe [Event]), TMVar a)
@@ -588,8 +600,8 @@ chanContents ch = do
 parsePresenceStatus
   :: ( MonadThrow m
      , MonadIO m
-     ) => Text -> NestingXML o m (Maybe StanzaType)
-parsePresenceStatus ns = do
+     ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
+parsePresenceStatus ns stanzaTag = do
 
     let toStat "away" = Away
         toStat "xa"   = ExtendedAway
@@ -619,9 +631,13 @@ parsePresenceStatus ns = do
     prio <- liftIO . atomically $ readTVar priov
     status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
                                             -- avoid multiple passes, but whatever.
+    let wlist = do
+            w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag)
+            Text.words w
     return . Just $ PresenceStatus { presenceShow = show
                                    , presencePriority = prio
                                    , presenceStatus = status
+                                   , presenceWhiteList = wlist
                                    }
 grokPresence
   :: ( MonadThrow m
@@ -630,9 +646,9 @@ grokPresence
 grokPresence ns stanzaTag = do
     let typ = lookupAttrib "type" (tagAttrs stanzaTag)
     case typ of
-        Nothing -> parsePresenceStatus ns
+        Nothing -> parsePresenceStatus ns stanzaTag
         Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline}))
-                                   $ parsePresenceStatus ns
+                                   $ parsePresenceStatus ns stanzaTag
         Just "error" -> return . Just $ PresenceInformError
         Just "unsubscribed" -> return . Just $ PresenceInformSubscription False
         Just "subscribed"   -> return . Just $ PresenceInformSubscription True
@@ -775,6 +791,7 @@ makePresenceStanza namespace mjid pstat = do
     stanzaFromList PresenceStatus { presenceShow = pstat
                                   , presencePriority = Nothing
                                   , presenceStatus = []
+                                  , presenceWhiteList = []
                                   }
       $ [ EventBeginElement (mkname namespace "presence")
             (setFrom $ typ pstat) ]