From b56ac5aa4a4d9c026f6aadad58daeee7729e9f4c Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 13 Jan 2020 05:28:21 -0500 Subject: Made client's handshake to/from attributes available to xmppTellNameToClient. --- dht/Presence/Nesting.hs | 10 ++- dht/Presence/Presence.hs | 39 ++++++---- dht/Presence/XMPPServer.hs | 173 ++++++++++++++++++++++++++++++--------------- dht/examples/dhtd.hs | 17 +++-- 4 files changed, 160 insertions(+), 79 deletions(-) diff --git a/dht/Presence/Nesting.hs b/dht/Presence/Nesting.hs index 403d63cf..a9e550d4 100644 --- a/dht/Presence/Nesting.hs +++ b/dht/Presence/Nesting.hs @@ -24,12 +24,10 @@ doNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m r doNestingXML m = evalStateC (XMLState 0 StrictNil) (trackNesting .| m) -startNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m (r, XMLState) -startNestingXML m = - runStateC (XMLState 0 StrictNil) (trackNesting .| m) - -finishNestingXML :: Monad m => XMLState -> NestingXML o m r -> ConduitM Event o m r -finishNestingXML = evalStateC +startNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m (r, NestingXML o m ()) +startNestingXML m = do + (r,st) <- runStateC (XMLState 0 StrictNil) (trackNesting .| m) + return (r, lift $ put st) nesting :: Monad m => NestingXML o m Int nesting = lift $ (return . nestingLevel) =<< get diff --git a/dht/Presence/Presence.hs b/dht/Presence/Presence.hs index 866aad78..c54c3659 100644 --- a/dht/Presence/Presence.hs +++ b/dht/Presence/Presence.hs @@ -13,6 +13,7 @@ import Control.Concurrent import Control.Concurrent.Lifted.Instrument #endif +import Control.Arrow import Control.Concurrent.STM import Control.Monad.Trans import Network.Socket ( SockAddr(..) ) @@ -133,17 +134,21 @@ newPresenceState cw toxman sv man = atomically $ do return $ st { toxManager = fmap ($ st) toxman } -nameForClient :: PresenceState stat -> ClientAddress -> IO Text -nameForClient state k = do +nameForClient' :: PresenceState stat -> Maybe Text -> Maybe Text -> ClientAddress -> IO Text +nameForClient' state mbNameForMe mbTheirName k = do mc <- atomically $ do cmap <- readTVar (clients state) return $ Map.lookup k cmap case mc of - Nothing -> textHostName + Nothing -> textHostName -- TODO: We can use mbNameForMe to initialize the clientProfile Just client -> case clientProfile client of "." -> textHostName profile -> return profile +nameForClient :: PresenceState stat -> ClientAddress -> IO Text +nameForClient state k = nameForClient' state Nothing Nothing k + + presenceHooks :: PresenceState stat -> Map Text MUC -> Int -> Maybe SockAddr -- ^ client-to-server bind address @@ -152,7 +157,7 @@ presenceHooks :: PresenceState stat -> Map Text MUC presenceHooks state chats verbosity mclient mpeer = XMPPServerParameters { xmppChooseResourceName = chooseResourceName state , xmppTellClientHisName = tellClientHisName state - , xmppTellMyNameToClient = nameForClient state + , xmppTellMyNameToClient = nameForClient' state , xmppTellMyNameToPeer = \(Local addr) -> return $ addrToText addr , xmppTellPeerHisName = return . peerKeyToText , xmppNewConnection = newConn state @@ -726,8 +731,12 @@ deliverMessage state fail msg = fromMaybe (do dput XJabber $ "Unknown peer " ++ show senderk fail) $ Map.lookup senderk pchans - <&> \(Conn { connChan = sender_chan - , auxData = ConnectionData (Left laddr) ctyp cprof _ }) -> do + <&> \Conn { connChan = sender_chan + , auxData = ConnectionData { cdAddr = Left laddr + , cdType = ctyp + , cdProfile = cprof + } + } -> do fromMaybe (do dput XJabber $ "Message missing \"to\" attribute." fail) $ (stanzaTo msg) <&> \to -> do @@ -916,9 +925,7 @@ informPeerPresence state k stanza = do dput XJabber $ "xmppInformPeerPresence (length clients="++show (length clients)++")" (ctyp,cprof) <- atomically $ do mconn <- Map.lookup k <$> readTVar (pkeyToChan state) - return $ fromMaybe (XMPP,".") $ do - ConnectionData _ ctyp cprof _ <- auxData <$> mconn - return (ctyp,cprof) + return $ fromMaybe (XMPP,".") $ (cdType &&& cdProfile) . auxData <$> mconn forM_ clients $ \(ck,con,client) -> do -- (TODO: appropriately authorized clients only.) -- For now, all "available" clients (available = sent initial presence) @@ -1263,7 +1270,11 @@ 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 { cdAddr = Left laddr + , cdType = ctyp + , cdProfile = profile + } + } -> do (mine,totup) <- case (ctyp,profile) of (Tox,p) -> let (u,h,r) = splitJID to in return ( h == p, (u,h,r) ) @@ -1412,8 +1423,12 @@ peerInformSubscription state fail k stanza = do cmap <- readTVar (clients state) return (pktc,cktc,cmap) fromMaybe fail $ Map.lookup k ktc - <&> \(Conn { connChan=sender_chan - , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do + <&> \Conn { connChan = sender_chan + , auxData = ConnectionData { cdAddr = Left laddr + , cdType = ctyp + , cdProfile = profile } + } -> do + let man = manager state profile (from_u,from_h,_) <- case ctyp of Tox -> return $ splitJID from diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs index 0aef1ed6..89fd76b6 100644 --- a/dht/Presence/XMPPServer.hs +++ b/dht/Presence/XMPPServer.hs @@ -129,8 +129,10 @@ data XMPPServerParameters = -- -- A Left result causes an error stanza to be sent instead. xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO (Either Text Text) - , -- | This should indicate the server's hostname that all client's see. - xmppTellMyNameToClient :: ClientAddress -> IO Text + , -- | This should indicate the server's hostname that the client will see. + -- The first two arguments are the "to" and "from" attributes, + -- respectively, that the client sent in its greeting to the server. + xmppTellMyNameToClient :: Maybe Text -> Maybe Text -> ClientAddress -> IO Text , xmppTellMyNameToPeer :: Local SockAddr -> IO Text , xmppTellClientHisName :: ClientAddress -> IO Text , xmppTellPeerHisName :: PeerAddress -> IO Text @@ -476,16 +478,14 @@ C->Unrecognized -- Sends all stanzas to announce channel except ping, for which it sends a pong -- to the output channel. -xmppInbound :: Maybe Text -- ^ "to" attribute sent from remote - -> Maybe Text -- ^ "from" attribute sent from remote - -> ConnectionData +xmppInbound :: ConnectionData -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) -> FlagCommand -- ^ action to check whether the connection needs a ping (XXX: unused) -> TChan Stanza -- ^ channel to announce incoming stanzas on -> TChan Stanza -- ^ channel used to send stanzas -> TMVar () -- ^ mvar that is filled when the connection quits -> NestingXML o IO () -xmppInbound stream_name stream_remote cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = +xmppInbound cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = fix $ \loop -> do -- liftIO . wlog $ "waiting for stanza." (chan,clsrs) <- liftIO . atomically $ @@ -540,7 +540,7 @@ xmppInbound stream_name stream_remote cdta (namespace,tellmyname,tellyourname,mk } stype -> ioWriteChan stanzas Stanza { stanzaType = case stype of - RequestResource _ rsc -> RequestResource stream_name rsc + RequestResource _ rsc -> RequestResource (cdTheirNameForMe cdta) rsc _ -> stype , stanzaId = mid , stanzaTo = mto @@ -911,44 +911,81 @@ forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event -> ConduitT (Flush XML.Event) Void IO () -> TChan Stanza -> MVar () - -> IO (TChan Stanza) -forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do + -> IO (TChan Stanza, ConnectionData) +forkConnection sv xmpp saddr cdta0 pingflag src snk stanzas pp_mvar = do -- client.PeerAddress {peerAddress = [::1]:5222} - let lbl n = concat [ n - , Text.unpack (Text.drop 7 namespace) -- "client" or "server" - , "." - , case cdProfile cdta of - _ | Right _ <- cdAddr cdta -> show saddr - "." -> show saddr - mytoxname -> show saddr {- TODO: remote tox peer name? -} ] + let auxAddr = cdAddr cdta0 - auxAddr = cdAddr cdta + is_client = case auxAddr of { Right _ -> True ; Left _ -> False } - clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of - Right _ -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr) - , xmppTellClientHisName xmpp (ClientAddress $ peerAddress saddr) - , ClientOrigin (ClientAddress $ peerAddress saddr)) - Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr - , xmppTellPeerHisName xmpp saddr - , PeerOrigin saddr) + (namespace,clientOrServer0) = case auxAddr of + Right _ -> ( "jabber:client" + , ( xmppTellMyNameToClient xmpp Nothing Nothing $ ClientAddress $ peerAddress saddr + , xmppTellClientHisName xmpp $ ClientAddress $ peerAddress saddr + , ClientOrigin $ ClientAddress $ peerAddress saddr ) ) + Left laddr -> ( "jabber:server" + , ( xmppTellMyNameToPeer xmpp laddr + , xmppTellPeerHisName xmpp saddr + , PeerOrigin saddr) ) + + updateNameField f (tmn,ttn,o) = (namespace,f tmn,ttn,o) + + lbl n = concat [ n + , Text.unpack (Text.drop 7 namespace) -- "client" or "server" + , "." + , case cdProfile cdta0 of + _ | Right _ <- auxAddr -> show saddr + "." -> show saddr + mytoxname -> show saddr {- TODO: remote tox peer name? -} ] + + + realDoGreeting = await >>= \case + Just EventBeginDocument -> + nextElement >>= \case + Just xml -> + forM (elementAttrs "stream" xml) $ \stream_attrs -> do + -- liftIO $ dput XMisc $ "STREAM ATTRS "++show 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 cdta0) stream_remote + return (stream_name, stream_remote) + Nothing -> return Nothing + _ -> return Nothing + + (clientOrServer@(namespace,tellmyname,telltheirname,_), (cdta, src', doGreeting)) + <- if is_client + then do + -- For a client, we can wait for them to greet us before we send them + -- any information. + (srcSealed,(mb,resume)) <- src $$+ startNestingXML realDoGreeting + let stream_name = mb >>= fst + stream_remote = mb >>= snd + cdta = cdta0 { cdTheirNameForMe = stream_name + , cdTheirName = stream_remote + } + newName _ = xmppTellMyNameToClient xmpp stream_name stream_remote + $ ClientAddress $ peerAddress saddr + atomically $ + modifyTVar' (conmap sv) $ + Map.adjust (\c -> c { cdata = cdta }) saddr + return ( updateNameField newName clientOrServer0 + , (cdta, unsealConduitT srcSealed, resume >> return mb) ) + else -- For a server, this is a no-op. + return ( updateNameField id clientOrServer0 + , (cdta0, src, realDoGreeting) ) output <- atomically newTChan rdone <- atomically newEmptyTMVar forkLabeled (lbl "xmpp-reader.") $ do -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show) - runConduit $ (.|) src $ + runConduit $ (.|) src' $ -- :: ConduitM Event o IO () 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 - stream_remote = lookupAttrib "from" stream_attrs - -- xmpp_version = lookupAttrib "version" stream_attrs - liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote - xmppInbound stream_name stream_remote cdta clientOrServer pingflag stanzas output rdone + doGreeting >>= \case + Just (stream_name, stream_remote) -> + xmppInbound cdta clientOrServer pingflag stanzas output rdone + Nothing -> return () atomically $ putTMVar rdone () wlog $ "end reader fork: " ++ lbl "" @@ -1087,7 +1124,7 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do ] what wlog $ "end xmpp-pre fork: " ++ show (lbl "") - return output + return (output, cdta) {- data Peer = Peer @@ -1121,7 +1158,9 @@ peerKey bind_addr (sock,(laddr,Remote raddr)) = do , ConnectionData { cdAddr = Left laddr , cdType = XMPP , cdProfile = "." - , cdRemoteName = rname } ) + , cdRemoteName = rname + , cdTheirNameForMe = Nothing + , cdTheirName = Nothing } ) clientKey :: SocketLike sock => (sock, (Local SockAddr,Remote SockAddr)) -> IO (PeerAddress,ConnectionData) clientKey (sock,(laddr,Remote raddr)) = do @@ -1138,7 +1177,9 @@ clientKey (sock,(laddr,Remote raddr)) = do , ConnectionData { cdAddr = Right (Remote raddr) -- FIXME: This is a bad way to detect client/peer. , cdType = XMPP , cdProfile = "." - , cdRemoteName = rname } ) + , cdRemoteName = rname + , cdTheirNameForMe = Nothing + , cdTheirName = Nothing } ) xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m () @@ -1154,17 +1195,18 @@ xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set) sendRoster :: StanzaWrap a + -> Server PeerAddress ConnectionData releaseKey xml -> XMPPServerParameters -> ClientAddress -> TChan Stanza -> IO () -sendRoster query xmpp clientKey replyto = do +sendRoster query sv xmpp clientKey replyto = do let maddr = case stanzaOrigin query of ClientOrigin addr _ -> Just addr PeerOrigin {} -> Nothing -- remote peer requested roster? LocalPeer -> Nothing -- local peer requested roster? forM_ maddr $ \k -> do - hostname <- xmppTellMyNameToClient xmpp clientKey + hostname <- svTellMyName sv xmpp clientKey let getlist f = do bs <- f xmpp k return (Set.fromList bs) -- js) @@ -1278,13 +1320,24 @@ makeErrorStanza' stanza err attrs = do , endTag ] +svTellMyName :: Server PeerAddress ConnectionData releaseKey xml + -> XMPPServerParameters + -> ClientAddress + -> IO Text +svTellMyName sv xmpp k@(ClientAddress saddr) = do + mc <- atomically $ + fmap cdata . Map.lookup (PeerAddress saddr) <$> readTVar (conmap sv) + let me = mc >>= cdTheirNameForMe + them = mc >>= cdTheirName + xmppTellMyNameToClient xmpp me them k + monitor :: Server PeerAddress ConnectionData releaseKey XML.Event -> ConnectionParameters PeerAddress ConnectionData -> XMPPServerParameters -> IO b monitor sv params xmpp = do - chan <- return $ serverEvent sv + let chan = serverEvent sv stanzas <- atomically newTChan quitVar <- atomically newEmptyTMVar pp_mvar <- newMVar () -- Lock for synchronous pretty-printing of stanzas in log. @@ -1296,16 +1349,18 @@ monitor sv params xmpp = do case e of Connection pingflag xsrc xsnk -> do wlog $ tomsg addr "Connection" - outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas pp_mvar + (outs,u') <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas pp_mvar -- /addr/ may be a peer or a client. So we'll strip off -- the PeerAddress constructor before exposing it. - xmppNewConnection xmpp (peerAddress addr) u outs + xmppNewConnection xmpp (peerAddress addr) u' outs ConnectFailure addr -> do return () -- wlog $ tomsg k "ConnectFailure" EOF -> do wlog $ tomsg addr "EOF" -- /addr/ may be a peer or a client. So we'll strip off -- the PeerAddress constructor before exposing it. - xmppEOF xmpp (peerAddress addr) u + xmppEOF xmpp (peerAddress addr) u -- Note: cdTheirName and cdTheirNameForMe are with their + -- default values rather than the updated versions provided + -- by 'forkConnection'. HalfConnection In -> do wlog $ tomsg addr "ReadOnly" case cdAddr u of @@ -1359,7 +1414,7 @@ monitor sv params xmpp = do $ \(k,((rkey,muckey),(replyto,r))) -> do (mine,ChatTransaction no cjid cnick es) <- readRoom k r return $ do - me <- xmppTellMyNameToClient xmpp k + me <- svTellMyName sv xmpp k dput XJabber $ "CHAT " ++ Text.unpack rkey ++ ": <" ++ Text.unpack cnick ++ "> " ++ show es forM_ es $ \case Join | mine -> sendRoomOccupants muckey me cnick rkey r replyto @@ -1387,7 +1442,7 @@ monitor sv params xmpp = do else Map.insert k m' jrs writeTVar joined_rooms jrs' Talk talk -> do - them <- xmppTellClientHisName xmpp k + them <- svTellMyName sv xmpp k stanza <- makeMessageEx "jabber:client" (roomjid muckey me rkey cnick) them GroupChatMsg talk ioWriteChan replyto stanza return () @@ -1475,7 +1530,7 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do sockaddr <- socketFromKey sv k xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted >>= \case Right rsc0 -> do - hostname <- xmppTellMyNameToClient xmpp k + hostname <- svTellMyName sv xmpp k let rsc = unsplitJID (n,hostname,r) where (n,_,r) = splitJID rsc0 let reply = iq_bind_reply (stanzaId stanza) rsc sendReply quitVar SetResource reply replyto @@ -1486,19 +1541,19 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do (requestVersion rsc hostname) >>= ioWriteChan replyto Left err -> do - hostname <- xmppTellMyNameToClient xmpp k + hostname <- svTellMyName sv xmpp k reply <- makeErrorStanza' stanza NotAllowed [] sendReply quitVar (Error NotAuthorized (head reply)) reply replyto SessionRequest -> do - me <- xmppTellMyNameToClient xmpp k + me <- svTellMyName sv xmpp k let reply = iq_session_reply (stanzaId stanza) me sendReply quitVar Pong reply replyto RequestRoster -> do - sendRoster stanza xmpp k replyto + sendRoster stanza sv xmpp k replyto xmppSubscribeToRoster xmpp k PresenceStatus {} -> do let mucs = xmppGroupChat xmpp - me <- xmppTellMyNameToClient xmpp k + me <- svTellMyName sv xmpp k if | Just to <- stanzaTo stanza , (Just room,h,mnick) <- splitJID to , let roomjid = unsplitJID ((Just room,h,Nothing)) @@ -1550,7 +1605,7 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do NotifyClientVersion name version -> do enableClientHacks name version replyto RequestInfo mnode -> do - me <- xmppTellMyNameToClient xmpp k + me <- svTellMyName sv xmpp k let unavail = let query = "{http://jabber.org/protocol/disco#info}info" reply = iq_service_unavailable (stanzaId stanza) me query in return (Error ServiceUnavailable (head reply), reply) @@ -1608,7 +1663,7 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do sendReply quitVar rtyp reply replyto RequestItems mnode -> do -- let query = "{http://jabber.org/protocol/disco#items}query" - me <- xmppTellMyNameToClient xmpp k + me <- svTellMyName sv xmpp k let unavail = let query = "{http://jabber.org/protocol/disco#info}info" reply = iq_service_unavailable (stanzaId stanza) me query in return (Error ServiceUnavailable (head reply), reply) @@ -1635,12 +1690,12 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do return (Items, reply) sendReply quitVar rtyp reply replyto UnrecognizedQuery query -> do - me <- xmppTellMyNameToClient xmpp k + me <- svTellMyName sv xmpp k let reply = iq_service_unavailable (stanzaId stanza) me query sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto Message { msgType = GroupChatMsg } -> do let mucs = xmppGroupChat xmpp - me <- xmppTellMyNameToClient xmpp k + me <- svTellMyName sv xmpp k if | Just to <- stanzaTo stanza , (Just room,h,mnick) <- splitJID to , let roomjid = unsplitJID ((Just room,h,Nothing)) @@ -1732,7 +1787,13 @@ data ConnectionData = ConnectionData -- Initially Nothing, when the remote end identifies itself by a given name, -- the result will be stored here. - , cdRemoteName :: TVar (Maybe Text) + , cdRemoteName :: TVar (Maybe Text) -- This is similar to 'cdTheirName' except that + -- it is available for remote xmpp servers and to + -- the 'xmppEOF' function. + , cdTheirNameForMe :: Maybe Text -- (client only) "to" attribute sent with + -- Also: currently unavailable to 'xmppEOF' + , cdTheirName :: Maybe Text -- (client only) "from" attribute sent with + -- Also: currently unavailable to 'xmppEOF' } addrToPeerKey :: Remote SockAddr -> PeerAddress diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs index d7c817ca..f9dc777d 100644 --- a/dht/examples/dhtd.hs +++ b/dht/examples/dhtd.hs @@ -1366,17 +1366,24 @@ onNewToxSession runio sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do uniqkey <- xor24 <$> hash24 (them netcrypto) <*> hash24 (me netcrypto) + let me_dot_tox = xmppHostname $ me netcrypto + them_dot_tox = xmppHostname $ them netcrypto + c <- atomically $ do mc <- Map.lookup uniqkey <$> readTVar ssvar case mc of Nothing -> do announce <- do - v <- newTVar Nothing + v <- newTVar $ Just them_dot_tox let ck = uniqueAsKey uniqkey - condta s = ConnectionData (Left (Local addrTox)) - XMPPServer.Tox - (xmppHostname $ me s) - v + condta s = ConnectionData + { cdAddr = Left (Local addrTox) + , cdType = XMPPServer.Tox + , cdProfile = me_dot_tox + , cdRemoteName = v + , cdTheirNameForMe = Just me_dot_tox + , cdTheirName = Just them_dot_tox + } return $ \s e -> writeTChan (xmppEventChannel sv) ( (ck, condta s), e) c <- newAggregateSession $ onStatusChange announce modifyTVar' ssvar $ Map.insert uniqkey c -- cgit v1.2.3