~singpolyma/cheogram

9dea3689a7f0de13ec462c8fc15a4a7aa36473d2 — Christopher Vollick 2 years ago 00ac243
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.
2 files changed, 65 insertions(+), 30 deletions(-)

M Main.hs
M Util.hs
M Main.hs => Main.hs +57 -30
@@ 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"

M Util.hs => Util.hs +8 -0
@@ 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
}