Replies to get-roster requests from client.

1 files changed, 44 insertions, 6 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index fb53c2fb..f25d3261 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -83,7 +83,7 @@ import Data.Conduit.Blaze
 import Data.List (find)
 import qualified Text.Show.ByteString as L
 import NestingXML
-import           Data.Set as Set (Set)
+import           Data.Set as Set (Set,(\\))
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import           Data.Map as Map (Map)
@@ -331,10 +331,48 @@ iq_service_unavailable host iq_id mjid req =
     , EventEndElement "{jabber:client}iq"
     ]
 
-getRoster session = do
-    budies <- getMyBuddies session
-    subscribers <- getMySubscribers session
-    return ([]::[Event]) -- TODO
+attr name value = (name,[ContentText value])
+
+getRoster session iqid = do
+    let getlist f = do
+            bs <- f session
+            -- js <- mapM parseHostNameJID bs
+            return (Set.fromList bs) -- js)
+    buddies     <- getlist getMyBuddies
+    subscribers <- getlist getMySubscribers
+    subnone     <- getlist getMyOthers
+    solicited   <- getlist getMySolicited
+    let subto = buddies \\ subscribers
+    let subfrom = subscribers \\ buddies
+    let subboth = Set.intersection buddies subscribers
+        -- solicited -> ask='subscribe'
+    jid <- getJID session
+    let dest = toStrict . L.decodeUtf8 . bshow $ jid
+    let items= (xmlify solicited "to" subto) 
+               ++(xmlify solicited "from" subfrom)
+               ++(xmlify solicited "both" subboth)
+               ++(xmlify solicited "none" subnone)
+        openiq =  [EventBeginElement "{jabber:client}iq"
+                    [ attr "id" iqid
+                    , attr "to" dest
+                    , attr "type" "result" ]
+                  ,EventBeginElement "{jabber:iq:roster}query"
+                    [] -- todo: ver? 
+                  ]
+        closeiq = [EventEndElement "{jabber:iq:roster}query"
+                  ,EventEndElement "{jabber:client}iq"]
+    return $ openiq ++ items ++ closeiq
+ where
+    xmlify solicited stype set = flip concatMap (Set.toList set) 
+      $ \jid -> 
+        [ EventBeginElement "item" 
+            ([("jid",[ContentText (toStrict . L.decodeUtf8 $ jid)])
+             ,("subscription",[ContentText stype])
+             ]++if Set.member jid solicited 
+                 then [("ask",[ContentText "subscribe"])] 
+                 else [] )
+        , EventEndElement "item"
+        ] 
 
 handleIQGet session cmdChan tag = do
     withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
@@ -371,7 +409,7 @@ handleIQGet session cmdChan tag = do
             --  [ContentText "32a337c2-7b22-45b6-9d21-15ded0d079ec"])
             -- ,(Name {nameLocalName = "type", nameNamespace = Nothing, namePrefix = Nothing},
             --  [ContentText "get"])]
-            roster <- getRoster session
+            roster <- getRoster session stanza_id
             atomically . writeTChan cmdChan . Send $ roster
         req -> unhandledGet req