send roster

2 files changed, 95 insertions, 7 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 52933440..d3df48d0 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -6,8 +6,9 @@ module XMPPServer
     , Stanza(..)
     , StanzaType(..)
     , StanzaOrigin(..)
-    , dupStanza
+    , cloneStanza
     ) where
+import Debug.Trace
 import Control.Monad.Trans.Resource (runResourceT)
 import Control.Monad.Trans (lift)
 import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -33,13 +34,16 @@ import Data.Conduit.Blaze (builderToByteStringFlush)
 import qualified Text.XML.Stream.Render as XML
 import qualified Text.XML.Stream.Parse as XML
 import Data.XML.Types as XML
-import Data.Maybe (catMaybes,fromJust,isNothing)
+import Data.Maybe (catMaybes,fromJust,isJust,isNothing)
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
 import qualified Data.Text as Text (pack,unpack)
 import Data.Char (toUpper)
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Set (Set, (\\) )
+import qualified Data.Set as Set
+import qualified System.Random 
 
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
 import ControlMaybe
@@ -85,6 +89,8 @@ data StanzaType
     | SetResource
     | SessionRequest
     | UnrecognizedQuery Name
+    | RequestRoster
+    | Roster
     | Error
     | PresenceStatus { presenceShow :: JabberShow
                      , presencePriority :: Maybe Int8
@@ -117,6 +123,12 @@ data XMPPServerParameters =
     { xmppChooseResourceName :: ConnectionKey -> Socket -> Maybe Text -> IO Text
     , xmppNewConnection :: ConnectionKey -> TChan Stanza -> IO ()
     , xmppEOF :: ConnectionKey -> IO ()
+    , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
+    , xmppRosterSubscribers  :: ConnectionKey -> IO [Text]
+    , xmppRosterSolicited    :: ConnectionKey -> IO [Text]
+    , xmppRosterOthers       :: ConnectionKey -> IO [Text]
+    , xmppLookupClientJID :: ConnectionKey -> IO Text
+    , xmppLookupPeerName  :: ConnectionKey -> IO Text
     }
 
 -- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
@@ -167,8 +179,8 @@ type FlagCommand = STM Bool
 type ReadCommand = IO (Maybe ByteString)
 type WriteCommand = ByteString -> IO Bool
 
-dupStanza stanza = do
-    dupped <- dupTChan (stanzaChan stanza)
+cloneStanza stanza = do
+    dupped <- cloneTChan (stanzaChan stanza)
     return stanza { stanzaChan = dupped }
 
 copyToChannel f chan closer_stack = awaitForever copy
@@ -223,6 +235,7 @@ grokStanzaIQGet stanza = do
     flip (maybe $ return Nothing)  mtag $ \tag -> do
     case tagName tag of
         "{urn:xmpp:ping}ping" -> return $ Just Ping
+        "{jabber:iq:roster}query" -> return $ Just RequestRoster
         name -> return . Just $ UnrecognizedQuery name
 
 grokStanzaIQResult :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
@@ -644,7 +657,7 @@ forkConnection sv k pingflag src snk stanzas = do
         fix $ \loop -> do
             what <- atomically $ foldr1 orElse
                 [readTChan output >>= \stanza -> return $ do
-                    dup <- atomically $ dupStanza stanza
+                    dup <- atomically $ cloneStanza stanza
                     stanzaToConduit dup $$ prettyPrint $ case k of
                         ClientKey {} -> "C<-" <> bshow (stanzaType dup) <> " "
                         PeerKey {}   -> "P<-" <> bshow (stanzaType dup) <> " "
@@ -712,12 +725,74 @@ stanzaToConduit stanza = do
                 cempty <- isEmptyTChan xchan
                 if isNothing mb
                     then if cempty then return loop else retry
-                    else retry -- todo: send closers
+                    else do done <- tryReadTMVar rdone
+                            check (isJust done)
+                            trace "todo: send closers" retry
             ,do isEmptyTChan xchan >>= check
                 readTMVar rdone
                 return (return ())]
         what
 
+xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
+xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set) 
+ where
+  item jid = do yield $ EventBeginElement "item" 
+                        ([ attr "jid" jid
+                         , attr "subscription" stype
+                         ]++if Set.member jid solicited 
+                             then [attr "ask" "subscribe"]
+                             else [] )
+                yield $ EventEndElement "item"
+
+sendRoster query xmpp replyto = do
+    let k = case stanzaOrigin query of
+             NetworkOrigin k _ -> Just k
+             LocalPeer -> Nothing -- local peer requested roster?
+    flip (maybe $ return ()) k $ \k -> do
+    jid <- case k of
+                ClientKey {} -> xmppLookupClientJID xmpp k
+                PeerKey {}   -> xmppLookupPeerName xmpp k
+    let getlist f = do
+            bs <- f xmpp k
+            -- js <- mapM parseHostNameJID bs
+            return (Set.fromList bs) -- js)
+    buddies     <- getlist xmppRosterBuddies
+    subscribers <- getlist xmppRosterSubscribers
+    solicited   <- getlist xmppRosterSolicited
+    subnone0    <- getlist xmppRosterOthers
+    let subnone = subnone0 \\ (Set.union buddies subscribers)
+    let subto = buddies \\ subscribers
+    let subfrom = subscribers \\ buddies
+    let subboth = Set.intersection buddies subscribers
+    let roster = do
+            yield $ EventBeginElement "{jabber:client}iq"
+                        (consid (stanzaId query)
+                            [ attr "to" jid
+                            , attr "type" "result" ])
+            yield $ EventBeginElement "{jabber:iq:roster}query" [] -- todo: ver? 
+            xmlifyRosterItems solicited "to" subto
+            xmlifyRosterItems solicited "from" subfrom
+            xmlifyRosterItems solicited "both" subboth
+            xmlifyRosterItems solicited "none" subnone
+            yield $ EventEndElement "{jabber:iq:roster}query"
+            yield $ EventEndElement "{jabber:client}iq"
+    chan <- atomically newTChan
+    clsrs <- atomically $ newTVar (Just [])
+    quitvar <- atomically $ newEmptyTMVar
+    forkIO $ do
+        roster =$= copyToChannel id chan clsrs $$ awaitForever (const $ return ())
+        atomically $ writeTVar clsrs Nothing
+    ioWriteChan replyto
+        Stanza  { stanzaType = Roster
+                , stanzaId = (stanzaId query)
+                , stanzaTo = Just jid
+                , stanzaFrom = Nothing
+                , stanzaChan = chan
+                , stanzaClosers = clsrs
+                , stanzaInterrupt = quitvar
+                , stanzaOrigin = LocalPeer
+                }
+
 socketFromKey :: Server k -> k -> IO Socket
 socketFromKey sv k = do
     return todo
@@ -758,6 +833,8 @@ monitor sv params xmpp = do
                         SessionRequest -> do
                             let reply = iq_session_reply (stanzaId stanza) "localhost"
                             sendReply quitVar Pong reply replyto
+                        RequestRoster ->
+                            sendRoster stanza xmpp replyto
                         UnrecognizedQuery query -> do
                             let reply = iq_service_unavailable (stanzaId stanza) "localhost" query
                             sendReply quitVar Error reply replyto
@@ -784,8 +861,13 @@ xmppServer :: ( MonadResource m
               ) => XMPPServerParameters -> m (Server ConnectionKey,ConnectionParameters ConnectionKey)
 xmppServer xmpp = do
     sv <- server
+    -- some fuzz helps avoid simultaneity
+    pingfuzz <- liftIO $ do
+        gen <- System.Random.getStdGen
+        let (r,gen') = System.Random.next gen
+        return $ r `mod` 2000 -- maximum 2 seconds of fuzz
     let peer_params = (connectionDefaults peerKey)
-                          { pingInterval = 15000
+                          { pingInterval = 15000 + pingfuzz
                           , timeout = 2000
                           , duplex = False }
         client_params = (connectionDefaults clientKey)
diff --git a/xmppServer.hs b/xmppServer.hs
index 4fcdd2c2..4601dbe9 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -21,6 +21,12 @@ main = runResourceT $ do
         { xmppChooseResourceName = \k sock desired -> return "nobody@localhost/tty666"
         , xmppNewConnection = \k outchan -> return ()
         , xmppEOF = \k -> return ()
+        , xmppRosterBuddies = \k -> return []
+        , xmppRosterSubscribers = \k -> return []
+        , xmppRosterSolicited = \k -> return []
+        , xmppRosterOthers = \k -> return []
+        , xmppLookupPeerName = \k ->  return "localhost"
+        , xmppLookupClientJID = \k -> return "nobody@localhost/tty666"
         }
     liftIO $ do
     let testaddr0 = "fd97:ca88:fa7c:b94b:c8b8:fad4:1021:a54d"