From 585e8aca57f0fdb09dd6cf42cb67af23448cdc6a Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 16 Feb 2014 16:02:17 -0500 Subject: send roster --- Presence/XMPPServer.hs | 96 ++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 89 insertions(+), 7 deletions(-) (limited to 'Presence/XMPPServer.hs') 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) -- cgit v1.2.3