From 87b3f98435ea74abfa72e120eca5940bb2974831 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 7 Sep 2018 11:38:07 -0400 Subject: xmpp: cache stream name --- Presence/Presence.hs | 65 ++++++++++++++++++++++++++-------- Presence/XMPPServer.hs | 94 +++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 125 insertions(+), 34 deletions(-) (limited to 'Presence') diff --git a/Presence/Presence.hs b/Presence/Presence.hs index 4f0deb32..fad87aeb 100644 --- a/Presence/Presence.hs +++ b/Presence/Presence.hs @@ -475,19 +475,49 @@ delclient k mlp = do eofConn :: PresenceState -> SockAddr -> ConnectionData -> IO () eofConn state saddr cdta = do - atomically $ case classifyConnection saddr cdta of - Left (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey - Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey case classifyConnection saddr cdta of Left (k,_) -> do - let h = peerKeyToText k + h <- case cdType cdta of + -- TODO: This should be cached (perhaps by rewriteJIDForClient?) so that we + -- guarantee that the OFFLINE message matches the ONLINE message. + -- For now, we reverse-resolve the peer key. + XMPP -> -- For XMPP peers, informPeerPresence expects a textual + -- representation of the IP address to reverse-resolve. + return $ peerKeyToText k + Tox -> do + -- For Tox peers, informPeerPresence expects the actual hostname + -- so we will use the one that the peer told us at greeting time. + m <- atomically $ swapTVar (cdRemoteName cdta) Nothing + case m of + Nothing -> do + dput XJabber $ "BUG: Tox peer didn't inform us of its name." + -- The following fallback behavior is probably wrong. + return $ peerKeyToText k + Just toxname -> return toxname + -- ioToSource terminated. + -- + -- dhtd: Network.Socket.getAddrInfo + -- (called with preferred socket type/protocol: AddrInfo + -- { addrFlags = [AI_NUMERICHOST], addrFamily = AF_UNSPEC + -- , addrSocketType = NoSocketType, addrProtocol = 0 + -- , addrAddress = + -- , addrCanonName = } + -- , host name: Just "DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox" + -- , service name: Just "0") + -- : does not exist (Name or service not known) + jids <- atomically $ do rbp <- readTVar (remotesByPeer state) return $ do umap <- maybeToList $ Map.lookup k rbp (u,rp) <- Map.toList umap r <- Map.keys (resources rp) - return $ unsplitJID (Just u, h, Just r) + let excludeEmpty "" = Nothing + excludeEmpty x = Just x + return $ unsplitJID (excludeEmpty u, h, excludeEmpty r) + -- EOF PEER PeerAddress [d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]:0: + -- ["@[d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]/"] + -- dput XJabber $ "EOF PEER "++show k++": "++show jids forM_ jids $ \jid -> do stanza <- makePresenceStanza "jabber:client" (Just jid) Offline informPeerPresence state k stanza @@ -502,6 +532,9 @@ eofConn state saddr cdta = do atomically $ do modifyTVar' (clientsByUser state) $ Map.alter (delclient k) (clientUser client) modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client) + atomically $ case classifyConnection saddr cdta of + Left (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey + Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey {- parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr)) @@ -594,8 +627,9 @@ deliverMessage state fail msg = -- Case 1. Client -> Peer mto <- join $ atomically $ do mclient <- Map.lookup senderk <$> readTVar (clients state) - return - $ fromMaybe -- Resolve XMPP peer. + return $ do + dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient) + fromMaybe -- Resolve XMPP peer. (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg)) $ do client <- mclient @@ -603,6 +637,7 @@ deliverMessage state fail msg = let (mu,th,rsc) = splitJID to (toxman,me,_) <- weAreTox state client th return $ do + dput XJabber $ "deliverMessage: weAreTox="++show me -- In case the client sends us a lower-cased version of the base64 -- tox key hostname, we resolve it by comparing it with roster entries. xs <- getBuddiesAndSolicited state (clientProfile client) $ \case @@ -637,7 +672,7 @@ deliverMessage state fail msg = fail) $ Map.lookup senderk pchans <&> \(Conn { connChan = sender_chan - , auxData = ConnectionData (Left laddr) ctyp cprof }) -> do + , auxData = ConnectionData (Left laddr) ctyp cprof _ }) -> do fromMaybe (do dput XJabber $ "Message missing \"to\" attribute." fail) $ (stanzaTo msg) <&> \to -> do @@ -777,7 +812,7 @@ informPeerPresence state k stanza = do let (muser0,h,mresource0) = splitJID from -- We'll allow the case that user and resource are simultaneously -- absent. They will be stored in the remotesByPeer map using the - -- empty string. This is to accomodate the tox protocol which didn't + -- empty string. This is to accommodate the tox protocol which didn't -- anticipate a single peer would have multiple users or front-ends. (muser,mresource) = case (muser0,mresource0) of (Nothing,Nothing) -> (Just "", Just "") @@ -826,14 +861,16 @@ informPeerPresence state k stanza = do (ctyp,cprof) <- atomically $ do mconn <- Map.lookup k <$> readTVar (pkeyToChan state) return $ fromMaybe (XMPP,".") $ do - ConnectionData _ ctyp cprof <- auxData <$> mconn + ConnectionData _ ctyp cprof _ <- auxData <$> mconn return (ctyp,cprof) forM_ clients $ \(ck,con,client) -> do -- (TODO: appropriately authorized clients only.) -- For now, all "available" clients (available = sent initial presence) is_avail <- atomically $ clientIsAvailable client when is_avail $ do - dput XJabber $ "reversing for client: " ++ show from + -- reversing for client: ("DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox" + -- ,XMPP,"OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox",".") + dput XJabber $ "reversing for client: " ++ show (from,ctyp,clientProfile client,cprof) froms <- case ctyp of Tox | clientProfile client == cprof -> return [from] _ -> do -- flip (maybe $ return [from]) k . const $ do @@ -1030,7 +1067,7 @@ clientSubscriptionRequest :: PresenceState -> IO () -> ClientAddress -> Stanza - clientSubscriptionRequest state fail k stanza chan = do forClient state k fail $ \client -> do fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do - dput XJabber $ "Forwarding solictation to peer" + dput XJabber $ "Forwarding solicitation to peer" let to0 = unsplitJID (mu,h,Nothing) -- deleted resource cuser = clientUser client cprof = clientProfile client @@ -1166,7 +1203,7 @@ peerSubscriptionRequest state fail k stanza chan = do cmap <- readTVar (clients state) return (pktc,cktc,cmap) fromMaybe fail $ (Map.lookup k pktc) - <&> \Conn { auxData=ConnectionData (Left laddr) ctyp profile } -> do + <&> \Conn { auxData=ConnectionData (Left laddr) ctyp profile _ } -> do (mine,totup) <- case (ctyp,profile) of (Tox,p) -> let (u,h,r) = splitJID to in return ( h == p, (u,h,r) ) @@ -1314,7 +1351,7 @@ peerInformSubscription state fail k stanza = do return (pktc,cktc,cmap) fromMaybe fail $ Map.lookup k ktc <&> \(Conn { connChan=sender_chan - , auxData =ConnectionData (Left laddr) ctyp profile}) -> do + , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do (from_u,from_h,_) <- case ctyp of Tox -> return $ splitJID from XMPP -> snd <$> rewriteJIDForClient laddr from [] diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index ae861a61..0d2d479b 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -42,6 +42,8 @@ module XMPPServer , greet' , (<&>) , grokStanza + , Uniq24(..) + , uniqueAsKey ) where import ConnectionKey @@ -56,6 +58,8 @@ import qualified Connection import Util import Network.Address (getBindAddress, sockAddrPort) +import Data.Bits +import Data.Word import Debug.Trace import Control.Monad.Trans (lift) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -908,7 +912,7 @@ makePong namespace mid to from = data ClientOrPeer = IsClient | IsPeer -xmppInbound :: Server SockAddr ConnectionData releaseKey XML.Event -- ^ XXX: unused +xmppInbound :: ConnectionData -> XMPPServerParameters -- ^ XXX: unused -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) -> FlagCommand -- ^ action to check whether the connection needs a ping (XXX: unused) @@ -916,14 +920,16 @@ xmppInbound :: Server SockAddr ConnectionData releaseKey XML.Event -- ^ XXX: unu -> TChan Stanza -- ^ channel used to send stanzas -> TMVar () -- ^ mvar that is filled when the connection quits -> ConduitM Event o IO () -xmppInbound sv xmpp (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do +xmppInbound cdta xmpp (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do withXML $ \begindoc -> do when (begindoc==EventBeginDocument) $ do whenJust nextElement $ \xml -> do withJust (elementAttrs "stream" xml) $ \stream_attrs -> do -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs - let stream_name = lookupAttrib "to" stream_attrs + let stream_name = lookupAttrib "to" stream_attrs + stream_remote = lookupAttrib "from" stream_attrs -- xmpp_version = lookupAttrib "version" stream_attrs + liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote fix $ \loop -> do -- liftIO . wlog $ "waiting for stanza." (chan,clsrs) <- liftIO . atomically $ @@ -1282,13 +1288,25 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do let lbl n = concat [ n , Text.unpack (Text.drop 7 namespace) , "." - , show saddr ] - forkIO $ do myThreadId >>= flip labelThread (lbl "post-queue.") + , case cdProfile cdta of + _ | Right _ <- cdAddr cdta -> show saddr + "." -> show saddr + mytoxname -> show saddr {- TODO: remote tox peer name? -} ] + + forkIO $ do myThreadId >>= flip labelThread (lbl "xmpp-post.") + -- This thread handles messages after they are pulled out of + -- the slots-queue. Hence, xmpp-post, for post- slots-queue. + + -- Read all slots-queued XML events or stanzas and yield them + -- upstream. This should continue until the connection is + -- closed. (greet_src >> slot_src) $$ snk + + -- Connection is now closed. Here we handle any unsent stanzas. last <- atomically $ readTVar lastStanza es <- while (atomically . fmap not $ Slotted.isEmpty slots) (atomically . Slotted.pull $ slots) - let es' = mapMaybe metadata es + let es' = mapMaybe metadata es -- We only care about full stanzas. metadata (Left s) = Just s metadata _ = Nothing -- TODO: Issuing RecipientUnavailable for all errors is a presence leak @@ -1304,17 +1322,21 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza notError s = case stanzaType s of Error {} -> False - _ -> True + _ -> True -- TODO: Probably some stanzas should be queued or saved for re-connect. mapM_ fail $ filter notError (maybeToList last ++ es') - wlog $ "end post-queue fork: " ++ (lbl "") + wlog $ "end xmpp-post fork: " ++ (lbl "") output <- atomically newTChan hacks <- atomically $ newTVar Map.empty msgids <- atomically $ newTVar [] forkIO $ do + -- Here is the pre- slots-queue thread which handles messages as they + -- arrive and assigns slots to them if that is appropriate. + -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer - myThreadId >>= flip labelThread (lbl "pre-queue.") + myThreadId >>= flip labelThread (lbl "xmpp-pre.") + verbosity <- xmppVerbosity xmpp fix $ \loop -> do what <- atomically $ foldr1 orElse @@ -1385,11 +1407,11 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do ,readTMVar rdone >> return (return ()) ] what - wlog $ "end pre-queue fork: " ++ show (lbl "") + wlog $ "end xmpp-pre fork: " ++ show (lbl "") forkIO $ do myThreadId >>= flip labelThread (lbl "reader.") -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show) - src $$ xmppInbound sv xmpp clientOrServer pingflag stanzas output rdone + src $$ xmppInbound cdta xmpp clientOrServer pingflag stanzas output rdone atomically $ putTMVar rdone () wlog $ "end reader fork: " ++ lbl "" return output @@ -1413,20 +1435,48 @@ peerKey bind_addr sock = do if c then getPeerName sock -- addr is normally socketName else return laddr -- Weird hack: addr is would-be peer name -- Assume remote peers are listening on the same port that we do. - let peerport = fromIntegral $ fromMaybe 5269 $ bind_addr >>= sockAddrPort + let peerport = fromIntegral $ fromMaybe 5269 $ do + p <- bind_addr >>= sockAddrPort + guard (p /= 0) -- Make sure we never use port 0 because it is used + -- to distinguish fake address connection keys. + return p + rname <- atomically $ newTVar Nothing return $ ( raddr `withPort` peerport - , ConnectionData { cdAddr = Left (Local laddr) - , cdType = XMPP - , cdProfile = "." } ) + , ConnectionData { cdAddr = Left (Local laddr) + , cdType = XMPP + , cdProfile = "." + , cdRemoteName = rname } ) clientKey :: SocketLike sock => sock -> IO (SockAddr,ConnectionData) clientKey sock = do laddr <- getSocketName sock raddr <- getPeerName sock + when (Just 0 == sockAddrPort laddr) $ do + dput XMan $ unwords [ "BUG: XMPP Client" + , show (laddr,raddr) + , "is using port zero. This could interfere" + , "with Tox peer sessions." ] + rname <- atomically $ newTVar Nothing return $ ( laddr - , ConnectionData { cdAddr = Right (Remote raddr) - , cdType = XMPP - , cdProfile = "." } ) + , ConnectionData { cdAddr = Right (Remote raddr) + , cdType = XMPP + , cdProfile = "." + , cdRemoteName = rname } ) + + +data Uniq24 = Uniq24 !Word64 !Word64 !Word64 + deriving (Eq,Ord,Show) + +uniqueAsKey :: Uniq24 -> SockAddr +uniqueAsKey (Uniq24 x y z) = SockAddrInet6 (fromIntegral 0) a bcde f + where + a = fromIntegral (x `shiftR` 32) + b = fromIntegral x + c = fromIntegral (y `shiftR` 32) + d = fromIntegral y + e = fromIntegral (z `shiftR` 32) + f = fromIntegral z + bcde = (b,c,d,e) xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m () xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set) @@ -1840,9 +1890,13 @@ data ConnectionData = ConnectionData , cdProfile :: Text -- Currently ignored for clients. Instead, see -- 'clientProfile' field of 'ClientState'. -- - -- For peers: "." for XMPP, otherwise the ".tox" hostname. + -- For peers: "." for XMPP, otherwise the ".tox" hostname + -- of this local node. + + -- Initially Nothing, when the remote end identifies itself by a given name, + -- the result will be stored here. + , cdRemoteName :: TVar (Maybe Text) } - deriving (Eq,Ord,Show) addrToPeerKey :: Remote SockAddr -> PeerAddress addrToPeerKey (Remote raddr) = PeerAddress raddr -- cgit v1.2.3