From 9dea3689a7f0de13ec462c8fc15a4a7aa36473d2 Mon Sep 17 00:00:00 2001 From: Christopher Vollick <0@psycoti.ca> Date: Mon, 15 Mar 2021 16:37:07 -0400 Subject: [PATCH] Add Audio to Caps if SIP Proxy is Present This should allow outgoing calls to contacts when a user has set themselves up to make calls. Along the way we adjusted the way disco is handed to the backend. Previously it would be sent with a special resource, and then that resource would be handled inbound so we know what kind of response we've just received. That allowed us to be stateless, but now that we have stateful things we want the ask the backend, it's much more useful to be able to send a query to the backend and handle the response, if there is one, while we still have the original request in scope. This same technique could be used for other flows we have, but doing so is outside the scope of this commit. --- Main.hs | 87 +++++++++++++++++++++++++++++++++++++-------------------- Util.hs | 8 ++++++ 2 files changed, 65 insertions(+), 30 deletions(-) diff --git a/Main.hs b/Main.hs index 4f5fbdb..a91363c 100644 --- a/Main.hs +++ b/Main.hs @@ -63,16 +63,16 @@ tcPut db cheoJid key val = liftIO $ do True <- TC.runTCM (TC.put db tck val) return () -queryDisco to from = queryDiscoWithNode Nothing to from +queryDisco to from = (:[]) . mkStanzaRec <$> queryDiscoWithNode Nothing to from queryDiscoWithNode node to from = do uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID - return [mkStanzaRec $ (emptyIQ IQGet) { + return $ (emptyIQ IQGet) { iqTo = Just to, iqFrom = Just from, iqID = uuid, iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") (map (\node -> (s"{http://jabber.org/protocol/disco#info}node", [ContentText node])) $ maybeToList node) [] - }] + } fillFormField var value form = form { elementNodes = map (\node -> @@ -170,6 +170,11 @@ telDiscoFeatures = [ s"urn:xmpp:jingle:transports:ibb:1" ] +getTelFeatures db jid = do + maybeProxy <- TC.runTCM (TC.get db (T.unpack (bareTxt jid) ++ "\0sip-proxy") :: TC.TCM (Maybe String)) + log "TELFEATURES" (jid, maybeProxy) + return $ maybe [] (const $ [s"urn:xmpp:jingle:transports:ice-udp:1", s"urn:xmpp:jingle:apps:dtls:0", s"urn:xmpp:jingle:apps:rtp:1", s"urn:xmpp:jingle:apps:rtp:audio"]) maybeProxy + telCapsStr extraVars = s"client/sms//Cheogram<" ++ mconcat (intersperse (s"<") (sort (nub (telDiscoFeatures ++ extraVars)))) ++ s"<" @@ -222,8 +227,23 @@ routeQueryOrReply db componentJid from smsJid resource query reply = do where maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/" ++ (fromString resource) +routeQueryStateful db componentJid sendIQ from smsJid query = do + maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route") + case (fmap fromString maybeRoute, maybeRouteFrom) of + (Just route, Just routeFrom) -> do + let routeTo = fromMaybe componentJid $ parseJID $ (maybe mempty (++ s"@") $ strNode <$> jidNode smsJid) ++ route + iqToSend <- query routeTo routeFrom + result <- atomicUIO =<< UIO.lift (sendIQ iqToSend) + return $ mfilter ((==IQResult) . iqType) result + _ -> return Nothing + where + maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/IQMANAGER" + +routeDiscoStateful db componentJid sendIQ from smsJid node = + routeQueryStateful db componentJid sendIQ from smsJid (queryDiscoWithNode node) + routeDiscoOrReply db componentJid from smsJid resource node reply = - routeQueryOrReply db componentJid from smsJid resource (queryDiscoWithNode node) reply + routeQueryOrReply db componentJid from smsJid resource (fmap (pure . mkStanzaRec) .: queryDiscoWithNode node) reply deliveryReceipt id from to = (emptyMessage MessageNormal) { @@ -638,7 +658,8 @@ data ComponentContext = ComponentContext { toRejoinManager :: TChan RejoinManagerCommand, toJoinPartDebouncer :: TChan JoinPartDebounce, processDirectMessageRouteConfig :: IQ -> IO IQ, - componentJid :: JID + componentJid :: JID, + sendIQ :: IQ -> UIO (STM (Maybe IQ)) } componentStanza :: ComponentContext -> ReceivedStanza -> IO [StanzaRec] @@ -774,6 +795,14 @@ componentStanza (ComponentContext { processDirectMessageRouteConfig, componentJi return [mkStanzaRec $ replyIQ { iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName) }] +componentStanza (ComponentContext { db, processDirectMessageRouteConfig, componentJid }) (ReceivedIQ iq@(IQ { iqTo = Just to, iqPayload = Just payload, iqFrom = Just from })) + | jidNode to == Nothing, + elementName payload == s"{http://jabber.org/protocol/commands}command", + attributeText (s"node") payload == Just (s"sip-proxy-set"), + [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren payload, + Just proxy <- getFormField form (s"sip-proxy") = do + True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) ++ "\0sip-proxy") $ T.unpack proxy + return [mkStanzaRec $ iqReply Nothing iq] componentStanza _ (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p })) | iqType iq `elem` [IQGet, IQSet], [_] <- isNamed (fromString "{jabber:iq:register}query") p = do @@ -829,11 +858,17 @@ componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ (IQ { iqType where extra = T.unpack $ escapeJid $ T.pack $ show (id, fromMaybe mempty resourceFrom) resourceFrom = strResource <$> jidResource from -componentStanza (ComponentContext { db, smsJid = (Just smsJid), componentJid }) (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p })) +componentStanza (ComponentContext { db, sendIQ, smsJid = (Just smsJid), componentJid }) (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p })) | Just _ <- jidNode to, [q] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do - routeDiscoOrReply db componentJid from smsJid ("CHEOGRAM%query-then-send-disco-info%" ++ extra) (nodeAttribute q) $ - telDiscoInfo q id to from [] + maybeDiscoResult <- routeDiscoStateful db componentJid sendIQ from smsJid (nodeAttribute q) + telFeatures <- getTelFeatures db from + case maybeDiscoResult of + Just (IQ { iqPayload = Just discoResult }) -> return [ + mkStanzaRec $ telDiscoInfo q id to from $ (telFeatures ++) $ mapMaybe (attributeText (fromString "var")) $ + isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren discoResult + ] + Nothing -> return [mkStanzaRec $ telDiscoInfo q id to from telFeatures] | Just tel <- strNode <$> jidNode to, [_] <- isNamed (s"{vcard-temp}vCard") p = do --owners <- (fromMaybe [] . (readZ =<<)) <$> @@ -955,12 +990,13 @@ componentStanza (ComponentContext { componentJid }) (ReceivedIQ (IQ { iqType = t else do let items = isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren p return [mkStanzaRec $ commandList componentJid iqId componentJid routeTo items] -componentStanza (ComponentContext { componentJid }) (ReceivedIQ (IQ { iqType = IQError, iqTo = Just to@(JID { jidNode = Just toNode }), iqFrom = Just from })) +componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ (IQ { iqType = IQError, iqTo = Just to@(JID { jidNode = Just toNode }), iqFrom = Just from })) | fmap strResource (jidResource to) == Just (s"CHEOGRAM%query-then-send-presence"), Just routeTo <- parseJID (unescapeJid (strNode toNode)), Just fromNode <- jidNode from, - Just routeFrom <- parseJID (strNode fromNode ++ s"@" ++ formatJID componentJid) = - return [ mkStanzaRec $ telAvailable routeFrom routeTo [] ] + Just routeFrom <- parseJID (strNode fromNode ++ s"@" ++ formatJID componentJid) = do + telFeatures <- getTelFeatures db routeTo + return [ mkStanzaRec $ telAvailable routeFrom routeTo telFeatures ] componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to@(JID { jidNode = Just toNode }), iqFrom = Just from, iqPayload = Just p })) | Just idAndResource <- T.stripPrefix (s"CHEOGRAM%query-then-send-ack%") . strResource =<< jidResource to, Just (messageId, resource) <- readZ $ T.unpack $ unescapeJid idAndResource, @@ -973,23 +1009,14 @@ componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ (IQ { iqType return [] else do return [mkStanzaRec $ deliveryReceipt messageId routeFrom routeTo] - | Just idAndResource <- T.stripPrefix (s"CHEOGRAM%query-then-send-disco-info%") . strResource =<< jidResource to, - Just (iqID, resource) <- readZ $ T.unpack $ unescapeJid idAndResource, - [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p, - Just routeTo <- parseJID (unescapeJid (strNode toNode) ++ if T.null resource then mempty else s"/" ++ resource), - Just fromNode <- jidNode from, - Just routeFrom <- parseJID (strNode fromNode ++ s"@" ++ formatJID componentJid) = do - return [ - mkStanzaRec $ telDiscoInfo query iqID routeFrom routeTo $ mapMaybe (attributeText (fromString "var")) $ - isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query - ] | fmap strResource (jidResource to) == Just (s"CHEOGRAM%query-then-send-presence"), [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p, Just routeTo <- parseJID (unescapeJid (strNode toNode)), Just fromNode <- jidNode from, Just routeFrom <- parseJID (strNode fromNode ++ s"@" ++ formatJID componentJid) = do + telFeatures <- getTelFeatures db routeTo return [ - mkStanzaRec $ telAvailable routeFrom routeTo $ mapMaybe (attributeText (fromString "var")) $ + mkStanzaRec $ telAvailable routeFrom routeTo $ (telFeatures ++) $ mapMaybe (attributeText (fromString "var")) $ isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query ] | [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do @@ -1093,7 +1120,7 @@ cacheOOB pushStatsd jingleStore jingleStoreURL m@(XMPP.Message { XMPP.messagePay (body, noOobsNoBody) = partition (\el -> XML.elementName el == bodyName) noOobs (oobs, noOobs) = partition (\el -> XML.elementName el == oobName) payloads -component db redis pushStatsd backendHost did cacheOOB adhocBotIQReceiver adhocBotMessage toRoomPresences toRejoinManager toJoinPartDebouncer toComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid registrationJids conferenceServers = do +component db redis pushStatsd backendHost did cacheOOB sendIQ iqReceiver adhocBotMessage toRoomPresences toRejoinManager toJoinPartDebouncer toComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid registrationJids conferenceServers = do sendThread <- forkXMPP $ forever $ flip catchError (log "component EXCEPTION") $ do stanza <- liftIO $ atomically $ readTChan toComponent @@ -1143,7 +1170,7 @@ component db redis pushStatsd backendHost did cacheOOB adhocBotIQReceiver adhocB Redis.exists bver -- Yes: done -- No: send disco query, with node - when (not exists) $ mapM_ sendToComponent =<< queryDiscoWithNode (Just $ node ++ s"#" ++ ver) from returnFrom + when (not exists) $ sendToComponent . mkStanzaRec =<< queryDiscoWithNode (Just $ node ++ s"#" ++ ver) from returnFrom -- No: write only availableness to redis. send disco query, no node _ -> do let val = LZ.toStrict $ Builder.toLazyByteString (Builder.word16BE pavailableness) @@ -1172,8 +1199,8 @@ component db redis pushStatsd backendHost did cacheOOB adhocBotIQReceiver adhocB _ -> return () flip forkFinallyXMPP (either (log "RECEIVE ONE" . show) return) $ case (stanzaFrom $ receivedStanza stanza, stanzaTo $ receivedStanza stanza, mapToBackend backendHost =<< stanzaTo (receivedStanza stanza), fmap strNode . jidNode =<< stanzaTo (receivedStanza stanza), stanza) of (_, Just to, _, _, ReceivedIQ iq@(IQ { iqType = IQResult })) - | (strResource <$> jidResource to) == Just (s"adhocbot") -> - adhocBotIQReceiver iq + | (strResource <$> jidResource to) `elem` map Just [s"adhocbot", s"IQMANAGER"] -> + iqReceiver iq (Just from, Just to, _, _, _) | strDomain (jidDomain from) == backendHost, to == componentJid -> @@ -1263,7 +1290,7 @@ component db redis pushStatsd backendHost did cacheOOB adhocBotIQReceiver adhocB (nameNamespace $ elementName p) `elem` [Just (s"urn:xmpp:jingle:1"), Just (s"http://jabber.org/protocol/ibb")] -> do jingleHandler iq | otherwise -> liftIO $ - mapM_ sendToComponent =<< componentStanza (ComponentContext db backendTo registrationJids adhocBotMessage cacheOOB toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid) stanza + mapM_ sendToComponent =<< componentStanza (ComponentContext db backendTo registrationJids adhocBotMessage cacheOOB toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid sendIQ) stanza where mapToComponent = mapToBackend (formatJID componentJid) sendToComponent = atomically . writeTChan toComponent @@ -1897,9 +1924,9 @@ main = do statsd <- openStatsD statsdHost (show statsdPort) ["cheogram"] - (adhocBotIQSender, adhocBotIQReceiver) <- iqManager $ atomicUIO . writeTChan sendToComponent . mkStanzaRec + (sendIQ, iqReceiver) <- iqManager $ atomicUIO . writeTChan sendToComponent . mkStanzaRec adhocBotMessages <- atomically newTChan - void $ forkIO $ adhocBotManager db componentJid (atomicUIO . writeTChan sendToComponent . mkStanzaRec) adhocBotIQSender (readTChan adhocBotMessages) + void $ forkIO $ adhocBotManager db componentJid (atomicUIO . writeTChan sendToComponent . mkStanzaRec) sendIQ (readTChan adhocBotMessages) void $ forkIO $ joinPartDebouncer db backendHost (atomically . writeTChan sendToComponent) componentJid toRoomPresences toJoinPartDebouncer void $ forkIO $ roomPresences db toRoomPresences @@ -1998,5 +2025,5 @@ main = do log "" "runComponent STARTING" log "runComponent ENDED" =<< runComponent (Server componentJid host (PortNumber port)) secret - (component db redis (UIO.lift . pushStatsd) backendHost did (cacheOOB (UIO.lift . pushStatsd) jingleStore jingleStoreURL) adhocBotIQReceiver (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences) + (component db redis (UIO.lift . pushStatsd) backendHost did (cacheOOB (UIO.lift . pushStatsd) jingleStore jingleStoreURL) sendIQ iqReceiver (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences) _ -> log "ERROR" "Bad arguments" diff --git a/Util.hs b/Util.hs index 310ab19..620486b 100644 --- a/Util.hs +++ b/Util.hs @@ -253,3 +253,11 @@ mapReceivedMessageM :: (Applicative f) => -> f XMPP.ReceivedStanza mapReceivedMessageM f (XMPP.ReceivedMessage m) = XMPP.ReceivedMessage <$> f m mapReceivedMessageM _ s = pure s + +iqReply :: Maybe XML.Element -> XMPP.IQ -> XMPP.IQ +iqReply payload iq = iq { + XMPP.iqType = XMPP.IQResult, + XMPP.iqFrom = XMPP.iqTo iq, + XMPP.iqTo = XMPP.iqFrom iq, + XMPP.iqPayload = payload +} -- 2.45.2