From 5d96f7581837e84b7e2db7f119879bc701709ddd Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 9 Jul 2013 01:40:47 -0400 Subject: send subscription requests to remote peers --- Presence/XMPP.hs | 79 ++++++++++++++++++++++++++++++++++----------------- Presence/XMPPTypes.hs | 2 +- Presence/main.hs | 25 ++++++++++------ 3 files changed, 71 insertions(+), 35 deletions(-) (limited to 'Presence') diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index a08c1a0e..735eaf3a 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -71,6 +71,7 @@ import Control.Monad as Monad import Text.XML.Stream.Parse (parseBytes,content) import Text.XML.Stream.Render import Data.XML.Types as XML +import qualified Data.Text as S (takeWhile) import Data.Text.Encoding as S (decodeUtf8,encodeUtf8) import Data.Text.Lazy.Encoding as L (decodeUtf8,encodeUtf8) import Data.Text.Lazy (toStrict) @@ -512,7 +513,7 @@ toClient session pchan cmdChan rchan = toClient' False False 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 + -- 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 @@ -712,18 +713,20 @@ presenceErrorRemoteNotFound iqid from to = return , EventEndElement "{stream:client}presence" ] +presenceSubscribed from = return + [ EventBeginElement "{stream:client}presence" + [ attr "from" from + , attr "type" "subscribed" + ] + , EventEndElement "{stream:client}presence" + ] + clientRequestsSubscription session cmdChan stanza = do - -- make bare jid - -- check local server and obey rules 3.1.3 of rfc 6121 - -- or forward to remote peer - -- or bail with type='error' as shown in 3.1.2 - -- if not bailed, - -- add to solicited - -- do roster push with subscription=none ask=subscribe liftIO $ do putStrLn $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza - withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do - let from = lookupAttrib "from" (tagAttrs stanza) + withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str0 -> do + let to_str = S.takeWhile (/='/') to_str0 + from = lookupAttrib "from" (tagAttrs stanza) iqid = lookupAttrib "id" (tagAttrs stanza) let handleError e | isDoesNotExistError e = do putStrLn $ "remote-server-not-found" @@ -732,12 +735,18 @@ clientRequestsSubscription session cmdChan stanza = do handleError e = do putStrLn $ "ERROR: "++ show e handleIO handleError $ do - to_jid <- parseHostNameJID (L.fromChunks [S.encodeUtf8 to_str]) - 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. + let to_str' = (L.fromChunks [S.encodeUtf8 to_str]) + to_jid <- fmap bare $ parseHostNameJID to_str' + if (is_remote . peer) to_jid + then do + addSolicited session to_str' to_jid + putStrLn $ "added to solicited: " ++ show to_jid + -- TODO: notify peer. + else do + -- addLocalSubscriber session to_str + -- self <- getJID session + r <- presenceSubscribed to_str -- self + atomically $ writeTChan cmdChan (Send r) return () peerRequestsSubsription session stanza = do @@ -807,14 +816,16 @@ fromPeer session = doNestingXML $ do -data OutBoundMessage = OutBoundPresence Presence | PresenceProbe JID JID +data OutBoundMessage = OutBoundPresence Presence + | PresenceProbe JID JID + | Solicitation JID JID deriving Prelude.Show newServerConnections = newTVar Map.empty data CachedMessages = CachedMessages { presences :: Map JID JabberShow - , probes :: Map JID (Set JID) + , probes :: Map JID (Set (Bool,JID)) } connect_to_server chan peer = (>> return ()) . runMaybeT $ do @@ -831,7 +842,11 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do writeIORef cached (cache { presences=Map.insert jid st . presences $ cache }) cacheCmd (PresenceProbe from to) cached = do cache <- readIORef cached - let probes' = Map.adjust (Set.insert from) to $ probes cache + let probes' = Map.adjust (Set.insert (True,from)) to $ probes cache + writeIORef cached (cache { probes=probes' }) + cacheCmd (Solicitation from to) cached = do + cache <- readIORef cached + let probes' = Map.adjust (Set.insert (False,from)) to $ probes cache writeIORef cached (cache { probes=probes' }) fix $ \sendmsgs -> do @@ -873,7 +888,7 @@ goodbyePeer = , EventEndDocument ] -presenceProbe sock fromjid tojid = do +presenceProbe sock fromjid tojid typ = do addr <- getSocketName sock let jidstr jid = toStrict . L.decodeUtf8 $ name jid <$++> "@" @@ -887,7 +902,7 @@ presenceProbe sock fromjid tojid = do [ EventBeginElement "{jabber:server}presence" [ attr "from" from , attr "to" to - , attr "type" "probe" + , attr "type" typ ] , EventEndElement "{jabber:server}presence" ] @@ -928,20 +943,29 @@ toPeer sock cache chan fail = do checkConnection cmd yieldOr r (fail . Just $ cmd) prettyPrint ">P: " r - sendProbe from to = do - r <- liftIO $ presenceProbe sock from to + sendProbe' from to typ = do + r <- liftIO $ presenceProbe sock from to typ let cmd = PresenceProbe from to checkConnection cmd yieldOr r (fail . Just $ cmd) prettyPrint ">P: " r + sendProbe from to = sendProbe' from to "probe" + sendSolicitation from to = sendProbe' from to "subscribe" send greetPeer forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do sendPresence (Presence jid st) forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do - forM_ (Set.toList froms) $ \from -> do - liftIO $ L.putStrLn "sending cached probe..." - sendProbe from to + forM_ (Set.toList froms) $ \(got,from) -> do + if got + then do + liftIO $ L.putStrLn "sending cached probe..." + sendProbe from to + else do + liftIO $ L.putStrLn "sending cached solicitation..." + sendSolicitation from to + + fix $ \loop -> do event <- lift . atomically $ readTChan chan case event of @@ -949,6 +973,9 @@ toPeer sock cache chan fail = do PresenceProbe from to -> do liftIO $ L.putStrLn "sending live probe..." sendProbe from to + Solicitation from to -> do + liftIO $ L.putStrLn "sending live solicitation..." + sendSolicitation from to loop send goodbyePeer diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs index 2bba8614..2bad795a 100644 --- a/Presence/XMPPTypes.hs +++ b/Presence/XMPPTypes.hs @@ -45,7 +45,7 @@ class JabberClientSession session where getMyOthers :: session -> IO [ByteString] getMyPending :: session -> IO [ByteString] getMySolicited :: session -> IO [ByteString] - addSolicited :: session -> ByteString -> IO () + addSolicited :: session -> ByteString -> JID -> IO () class JabberPeerSession session where data XMPPPeerClass session diff --git a/Presence/main.hs b/Presence/main.hs index bbaac97a..036d7237 100644 --- a/Presence/main.hs +++ b/Presence/main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TupleSections #-} module Main where import System.Directory @@ -196,15 +197,19 @@ instance JabberClientSession ClientSession where L.putStrLn $ "cached presence: " <++> bshow p action p - addSolicited s jid = do - user <- readIORef (unix_uid s) >>= getJabberUserForId - addJid ConfigFiles.modifySolicited user jid + addSolicited s jid_str jid = do + me <- getJID s + withJust (name me) $ \user -> do + addJid ConfigFiles.modifySolicited user jid_str let rchan = rosterChannel . presence_state $ s atomically $ do isempty <- isEmptyTMVar rchan when (not isempty) $ do (_,ch) <- readTMVar rchan - writeTChan ch (RequestedSubscription user jid) + writeTChan ch (RequestedSubscription user jid_str) + sendMessage (outGoingConnections . presence_state $ s) + (Solicitation me jid) + (peer jid) getMyBuddies s = do @@ -381,16 +386,20 @@ sendProbes state jid = do buddies <- ConfigFiles.getBuddies user fmap catMaybes (mapM parseHostNameJID' buddies) L.putStrLn $ "buddies for " <++> bshow jid <++> " = " <++> bshow buddies + wanted <- do + wanted <- ConfigFiles.getSolicited user + fmap catMaybes (mapM parseHostNameJID' wanted) remotes <- readTVarIO (remoteUsers state) - forM_ buddies $ \buddy -> do + forM_ (map (True,) buddies ++ map (False,) wanted) $ \(got,buddy) -> do let mjids = fmap snd $ Map.lookup (peer buddy) remotes jids <- maybe (return MM.empty) readTVarIO mjids withJust (splitResource buddy) $ \(buddyU,_) -> do let noinfo = not (MM.member buddyU jids) when noinfo $ do - L.putStrLn $ "sendMessage " <++> bshow (PresenceProbe jid buddy) - sendMessage (outGoingConnections state) (PresenceProbe jid buddy) (peer buddy) - return () + let msg = if got then PresenceProbe jid buddy else Solicitation jid buddy + L.putStrLn $ "sendMessage " <++> bshow msg + sendMessage (outGoingConnections state) msg (peer buddy) + track_login host state e = do #ifndef NOUTMP -- cgit v1.2.3