From 88274ed5e6d6ffa37683c7e213095d23fd31decd Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 8 Jul 2013 21:15:37 -0400 Subject: Send roster push events to client in case of subscription requests. --- Presence/XMPP.hs | 67 ++++++++++++++++++++++++++++++++++++++++++--------- Presence/XMPPTypes.hs | 6 +++++ Presence/main.hs | 42 +++++++++++++++++++++++++++++--- 3 files changed, 100 insertions(+), 15 deletions(-) diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index 1520839e..a08c1a0e 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -470,19 +470,59 @@ prettyPrint prefix xs = liftIO $ do CL.sourceList xs $= renderBytes (def { rsPretty=True }) =$= CB.lines $$ CL.mapM_ (S.putStrLn . (prefix `S.append`)) -toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m [XML.Event] -toClient pchan cmdChan = fix $ \loop -> do - let send xs = yield xs >> prettyPrint ">C: " xs + +rosterPush to contact attrs = do + let n = name to + rsc = resource to + names <- getNamesForPeer (peer to) + let tostr p = L.decodeUtf8 $ n <$++> "@" L.fromChunks [p] <++?> "/" <++$> rsc + jidstrs = fmap (toStrict . tostr) names + tojid = head jidstrs + return + [ EventBeginElement "{jabber:client}iq" + [ attr "to" tojid + , attr "id" "someid" + , attr "type" "set" + ] + , EventBeginElement "{jabber:iq:roster}query" [] + , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs) + , EventEndElement "{jabber:iq:roster}item" + , EventEndElement "{jabber:iq:roster}query" + , EventEndElement "{jabber:client}iq" + ] + +data EventsForClient = CmdChan Commands + | PChan Presence + | RChan RosterEvent + +toClient :: (MonadIO m, JabberClientSession session ) => + session -> TChan Presence -> TChan Commands -> TChan RosterEvent -> Source m [XML.Event] +toClient session pchan cmdChan rchan = toClient' False False + where + toClient' isBound isInterested = do + let loop = toClient' isBound isInterested + send xs = yield xs >> prettyPrint ">C: " xs event <- liftIO . atomically $ - orElse (fmap Left $ readTChan pchan) - (fmap Right $ readTChan cmdChan) + foldr1 orElse [fmap PChan $ readTChan pchan + ,fmap RChan $ readTChan rchan + ,fmap CmdChan $ readTChan cmdChan + ] case event of - Right QuitThread -> return () - Right (Send xs) -> send xs >> loop - Right cmd -> liftIO (putStrLn $ "unhandled event: "++show cmd) >> loop - Left presence -> do - xs <- liftIO $ xmlifyPresenceForClient presence - send xs + CmdChan QuitThread -> return () + CmdChan (Send xs) -> send xs >> loop + CmdChan BoundToResource -> toClient' True isInterested + CmdChan InterestedInRoster -> toClient' isBound True + CmdChan cmd -> liftIO (putStrLn $ "unhandled event: "++show cmd) >> loop + RChan (RequestedSubscription who contact) -> do + jid <- liftIO $ getJID session + when (isInterested && Just who==name jid) $ do + r <- liftIO $ rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "ask" "subscribe"] + send r + loop + PChan presence -> do + when isBound $ do + xs <- liftIO $ xmlifyPresenceForClient presence + send xs loop handleClient @@ -496,10 +536,11 @@ handleClient st src snk = do session <- newSession session_factory sock Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname pchan <- subscribe session Nothing + rchan <- subscribeToRoster session cmdChan <- atomically newTChan #ifdef RENDERFLUSH - writer <- async ( toClient pchan cmdChan + writer <- async ( toClient session pchan cmdChan rchan $$ flushList =$= renderBuilderFlush def =$= builderToByteStringFlush @@ -695,6 +736,8 @@ clientRequestsSubscription session cmdChan stanza = do addSolicited session (L.fromChunks [S.encodeUtf8 to_str]) -- jid putStrLn $ "added to solicited: " ++ show to_jid -- TODO: create roster item and push to interested clients + -- addSolicited should write event to a roster channel + -- that toClient will be listening on. return () peerRequestsSubsription session stanza = do diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs index 301f19fd..2bba8614 100644 --- a/Presence/XMPPTypes.hs +++ b/Presence/XMPPTypes.hs @@ -38,6 +38,7 @@ class JabberClientSession session where getJID :: session -> IO JID closeSession :: session -> IO () subscribe :: session -> Maybe JID -> IO (TChan Presence) + subscribeToRoster :: session -> IO (TChan RosterEvent) forCachedPresence :: session -> (Presence -> IO ()) -> IO () getMyBuddies :: session -> IO [ByteString] getMySubscribers :: session -> IO [ByteString] @@ -72,6 +73,11 @@ data JabberShow = Offline data Presence = Presence JID JabberShow deriving Prelude.Show +data RosterEvent = RequestedSubscription + {- user: -} ByteString + {- contact: -} ByteString + deriving Prelude.Show + data Peer = LocalHost | RemotePeer SockAddr deriving (Eq,Prelude.Show) diff --git a/Presence/main.hs b/Presence/main.hs index bf4809a8..a7ff5e5a 100644 --- a/Presence/main.hs +++ b/Presence/main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} module Main where import System.Directory @@ -79,6 +80,7 @@ data PresenceState = PresenceState , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) -- UNUSED as yet , localSubscriber :: TMVar (RefCount,TChan Presence) -- TODO: rename this, its not just locals -- ... or make a seperate channel for remotes + , rosterChannel :: TMVar (RefCount,TChan RosterEvent) , remoteUsers :: TVar (Map Peer (RefCount,TVar (MultiMap JabberUser (JabberResource,JabberShow)))) , outGoingConnections :: TVar (Map Peer (TChan OutBoundMessage, ThreadId)) } @@ -99,6 +101,7 @@ data ClientSession = ClientSession { localhost :: Peer, -- ByteString, unix_uid :: (IORef (Maybe (UserID,L.ByteString))), unix_resource :: (IORef (Maybe L.ByteString)), + chans :: TVar [RefCountedChan], presence_state :: PresenceState } @@ -112,7 +115,8 @@ instance JabberClientSession ClientSession where L.putStrLn $ "CLIENT SESSION: open " <++> bshow muid uid_ref <- newIORef muid res_ref <- newIORef Nothing - return $ ClientSession (hostname state) uid_ref res_ref state + chans <- atomically $ newTVar [] + return $ ClientSession (hostname state) uid_ref res_ref chans state setResource s resource = do -- TODO: handle resource = empty string @@ -137,15 +141,30 @@ instance JabberClientSession ClientSession where return (JID (Just user) host rsc) closeSession session = do + atomically $ do + cs <- readTVar (chans session) + forM_ cs $ \(RefCountedChan c) -> do + unsubscribeToChan c L.putStrLn "CLIENT SESSION: close" subscribe session Nothing = do let tmvar = localSubscriber (presence_state session) - atomically $ subscribeToChan tmvar + atomically $ do + cs <- readTVar (chans session) + writeTVar (chans session) (RefCountedChan tmvar:cs) + subscribeToChan tmvar subscribe session (Just jid) = do -- UNUSED as yet let tvar = subscriberMap (presence_state session) atomically $ subscribeToMap tvar jid + subscribeToRoster session = do + let rchan = rosterChannel . presence_state $ session + atomically $ do + cs <- readTVar (chans session) + writeTVar (chans session) (RefCountedChan rchan:cs) + subscribeToChan rchan + + forCachedPresence s action = do jid <- getJID s L.putStrLn $ "forCachedPresence "<++> bshow jid @@ -171,6 +190,13 @@ instance JabberClientSession ClientSession where addSolicited s jid = do user <- readIORef (unix_uid s) >>= getJabberUserForId ConfigFiles.addSolicited user jid -- (L.show jid) + let rchan = rosterChannel . presence_state $ s + atomically $ do + isempty <- isEmptyTMVar rchan + when (not isempty) $ do + (_,ch) <- readTMVar rchan + writeTChan ch (RequestedSubscription user jid) + getMyBuddies s = do user <- readIORef (unix_uid s) >>= getJabberUserForId @@ -251,6 +277,9 @@ instance JabberPeerSession PeerSession where getSubscribers _ user = ConfigFiles.getSubscribers user +data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a)) + +subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a) subscribeToChan tmvar = (do (cnt,chan) <- takeTMVar tmvar putTMVar tmvar (cnt+1,chan) @@ -260,6 +289,12 @@ subscribeToChan tmvar = (do chan <- newTChan putTMVar tmvar (1,chan) return chan ) +unsubscribeToChan :: TMVar (RefCount,TChan a) -> STM () +unsubscribeToChan tmvar = do + isEmpty <- isEmptyTMVar tmvar + when (not isEmpty) $ do + (cnt,chan) <- takeTMVar tmvar + when (cnt>1) (putTMVar tmvar (cnt-1,chan)) getRefFromMap tvar key newObject copyObject = do subs <- readTVar tvar @@ -322,9 +357,10 @@ newPresenceState hostname = atomically $ do us <- newTVar (Set.empty) subs <- newTVar (Map.empty) locals_greedy <- newEmptyTMVar + rchan <- newEmptyTMVar remotes <- newTVar (Map.empty) server_connections <- newServerConnections - return $ PresenceState hostname tty us subs locals_greedy remotes server_connections + return $ PresenceState hostname tty us subs locals_greedy rchan remotes server_connections sendProbes state jid = do L.putStrLn $ "sending probes for " <++> bshow jid -- cgit v1.2.3