~singpolyma/cheogram

14a11481642b9b777868049b646116b24c12d754 — Stephen Paul Weber 3 years ago 80a20c9
Pass through command list from direct route
1 files changed, 78 insertions(+), 40 deletions(-)

M Main.hs
M Main.hs => Main.hs +78 -40
@@ 71,6 71,17 @@ queryDisco to from = do
		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] []
	}]

queryCommandList to from = do
	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
	return [mkStanzaRec $ (emptyIQ IQGet) {
		iqTo = Just to,
		iqFrom = Just from,
		iqID = uuid,
		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#items}query") [
			(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])
		] []
	}]

fillFormField var value form = form {
		elementNodes = map (\node ->
			case node of


@@ 204,16 215,46 @@ telDiscoInfo id from to disco =
			) (sort $ nub $ telDiscoFeatures ++ disco)
	}

routeDiscoOrReply db componentJid from smsJid resource reply = do
commandList componentJid id from to extras =
	(emptyIQ IQResult) {
		iqTo = Just to,
		iqFrom = Just from,
		iqID = id,
		iqPayload = Just $ Element (s"{http://jabber.org/protocol/disco#items}query")
			[(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])]
			([
				NodeElement $ Element (s"{http://jabber.org/protocol/disco#items}item") [
						(s"{http://jabber.org/protocol/disco#items}jid", [ContentText $ formatJID componentJid ++ s"/" ++ ConfigureDirectMessageRoute.nodeName]),
						(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ ConfigureDirectMessageRoute.nodeName]),
						(s"{http://jabber.org/protocol/disco#items}name", [ContentText $ s"Configure direct message route"])
				] []
			] ++ extraItems)
	}
	where
	extraItems = map (\el ->
			NodeElement $ el {
				elementAttributes = map (\(aname, acontent) ->
					if aname == s"{http://jabber.org/protocol/disco#items}jid" || aname == s"jid" then
						(aname, [ContentText $ formatJID componentJid ++ s"/route-command"])
					else
						(aname, acontent)
				) (elementAttributes el)
			}
		) extras

routeQueryOrReply db componentJid from smsJid resource query reply = do
	maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
	case (fmap fromString maybeRoute, maybeRouteFrom) of
		(Just route, Just routeFrom) ->
				let routeTo = fromMaybe componentJid $ parseJID $ (fromMaybe mempty $ strNode <$> jidNode smsJid) ++ s"@" ++ route in
				queryDisco routeTo routeFrom
				let routeTo = fromMaybe componentJid $ parseJID $ (maybe mempty (++ s"@") $ strNode <$> jidNode smsJid) ++ route in
				query routeTo routeFrom
		_ -> return [mkStanzaRec $ reply]
	where
	maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/" ++ (fromString resource)

routeDiscoOrReply db componentJid from smsJid resource reply =
	routeQueryOrReply db componentJid from smsJid resource queryDisco reply

deliveryReceipt id from to =
	(emptyMessage MessageNormal) {
		messageFrom = Just from,


@@ 596,7 637,7 @@ handleRegister _ _ iq _ = do
	log "HANDLEREGISTER UNKNOWN" iq
	return []

componentStanza db Nothing _ _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just (JID { jidNode = Nothing }), messageFrom = Just from})) = return [
componentStanza db _ _ _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just (JID { jidNode = Nothing }), messageFrom = Just from})) = return [
		mkStanzaRec $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs.  Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
	]
componentStanza _ _ _ _ _ _ _ _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))


@@ 706,7 747,7 @@ componentStanza _ _ _ _ _ _ processDirectMessageRouteConfig componentJid (Receiv
			iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName)
		}]
componentStanza _ _ _ _ _ _ processDirectMessageRouteConfig componentJid (ReceivedIQ iq@(IQ { iqTo = Just to, iqPayload = payload }))
	| (jidNode to == Nothing && fmap elementName payload == Just (s"{http://jabber.org/protocol/commands}command")) ||
	| (jidNode to == Nothing && fmap elementName payload == Just (s"{http://jabber.org/protocol/commands}command") && (attributeText (s"node") =<< payload) == Just ConfigureDirectMessageRoute.nodeName) ||
	  fmap strResource (jidResource to) == Just (s"CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName) = do
		log "PART OF COMMAND" iq
		replyIQ <- processDirectMessageRouteConfig iq


@@ 719,7 760,7 @@ componentStanza db _ _ _ _ _ _ componentJid (ReceivedIQ iq@(IQ { iqFrom = Just _
	  [query] <- isNamed (fromString "{jabber:iq:register}query") p = do
		log "LOOKS LIKE REGISTRATION" iq
		return [mkStanzaRec $ iqNotImplemented iq]
componentStanza _ _ _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p }))
componentStanza db _ _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p }))
	| Nothing <- jidNode to,
	  [_] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
		log "DISCO ON US" (from, to, p)


@@ 752,20 793,7 @@ componentStanza _ _ _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqF
	  [s"http://jabber.org/protocol/commands"] ==
	    mapMaybe (attributeText (s"node")) (isNamed (fromString "{http://jabber.org/protocol/disco#items}query") p) = do
		log "componentStanza QUERY FOR COMMAND LIST" to
		return [mkStanzaRec $ (emptyIQ IQResult) {
			iqTo = Just from,
			iqFrom = Just to,
			iqID = id,
			iqPayload = Just $ Element (s"{http://jabber.org/protocol/disco#items}query")
				[(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])]
				[
					NodeElement $ Element (s"{http://jabber.org/protocol/disco#items}item") [
							(s"{http://jabber.org/protocol/disco#items}jid", [ContentText $ formatJID componentJid ++ s"/" ++ ConfigureDirectMessageRoute.nodeName]),
							(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ ConfigureDirectMessageRoute.nodeName]),
							(s"{http://jabber.org/protocol/disco#items}name", [ContentText $ s"Configure direct message route"])
					] []
				]
		}]
		routeQueryOrReply db componentJid from componentJid ("CHEOGRAM%query-then-send-command-list%" ++ extra) queryCommandList (commandList componentJid id to from [])
	| Nothing <- jidNode to,
	  [_] <- isNamed (s"{vcard-temp}vCard") p =
		return [mkStanzaRec $ (emptyIQ IQResult) {


@@ 778,6 806,9 @@ componentStanza _ _ _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqF
					NodeElement $ Element (s"{vcard-temp}DESC") [] [NodeContent $ ContentText $ s"Cheogram provides stable JIDs for PSTN identifiers, with routing through many possible backends.\n\n© Stephen Paul Weber, licensed under AGPLv3+.\n\nSource code for this gateway is available from the listed homepage.\n\nPart of the Soprani.ca project."]
				]
		}]
	where
	extra = T.unpack $ escapeJid $ T.pack $ show (id, fromMaybe mempty resourceFrom)
	resourceFrom = strResource <$> jidResource from
componentStanza db (Just smsJid) _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p }))
	| Just _ <- jidNode to,
	  [_] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do


@@ 905,6 936,18 @@ componentStanza _ (Just smsJid) _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqTy
		fmap (((mkStanzaRec $ mkSMS componentJid smsJid (mconcat [fromString "* You have created ", bareTxt from])):) . concat . toList) $
			forM (parseJID $ bareTxt to <> fromString "/create") $
				queryDisco from
componentStanza db _ _ _ _ _ _ componentJid (ReceivedIQ iq@(IQ { iqType = typ, iqTo = Just to@(JID { jidNode = Just toNode }), iqPayload = Just p }))
	| typ `elem` [IQResult, IQError],
	  Just idAndResource <- T.stripPrefix (s"CHEOGRAM%query-then-send-command-list%") . strResource =<< jidResource to,
	  Just (iqId, resource) <- readZ $ T.unpack $ unescapeJid idAndResource,
	  Just routeTo <- parseJID (unescapeJid (strNode toNode) ++ if T.null resource then mempty else s"/" ++ resource) =
		if typ == IQError then do
			log "ERROR FROM ROUTE, SEND DEFAULT COMMAND LIST" iq
			return [mkStanzaRec $ commandList componentJid iqId componentJid routeTo []]
		else do
			log "COMMANDS FROM ROUTE, MERGE WITH OURS AND SEND" iq
			let items = isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren p
			return [mkStanzaRec $ commandList componentJid iqId componentJid routeTo items]
componentStanza 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,


@@ 961,25 1004,20 @@ componentStanza _ _ _ _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFrom = Ju
			iqType = IQResult,
			iqPayload = Nothing
		}]
componentStanza db maybeSmsJid _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = typ, iqFrom = Just from }))
	| Just smsJid <- maybeSmsJid,
	  Just _ <- jidNode =<< iqTo iq = do
		let resourceSuffix = maybe mempty (s"/"++) $ fmap strResource (jidResource from)
		maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
		case (fmap fromString maybeRoute, parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ resourceSuffix) of
			(Just route, Just routeFrom) -> do
				log "IQ ROUTE" route
				return [mkStanzaRec $ iq {
					iqFrom = Just routeFrom,
					iqTo = parseJID $ (fromMaybe mempty $ strNode <$> jidNode smsJid) ++ s"@" ++ route
				}]
			_ | typ `elem` [IQGet, IQSet] -> do
				log "REPLY WITH IQ ERROR (no route)" iq
				return [mkStanzaRec $ iqNotImplemented iq]
			_ -> log "IGNORE BOGUS REPLY (no route)" iq >> return []
	| typ `elem` [IQGet, IQSet] = do
		log "REPLY WITH IQ ERROR" iq
		return [mkStanzaRec $ iqNotImplemented iq]
componentStanza db maybeSmsJid _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = typ, iqFrom = Just from })) = do
	let resourceSuffix = maybe mempty (s"/"++) $ fmap strResource (jidResource from)
	maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
	case (fmap fromString maybeRoute, parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ resourceSuffix) of
		(Just route, Just routeFrom) -> do
			log "IQ ROUTE" route
			return [mkStanzaRec $ iq {
				iqFrom = Just routeFrom,
				iqTo = parseJID $ (maybe mempty (++s"@") $ strNode <$> (jidNode =<< maybeSmsJid)) ++ route
			}]
		_ | typ `elem` [IQGet, IQSet] -> do
			log "REPLY WITH IQ ERROR (no route)" iq
			return [mkStanzaRec $ iqNotImplemented iq]
		_ -> log "IGNORE BOGUS REPLY (no route)" iq >> return []
componentStanza _ _ _ _ _ _ _ _ s = do
	log "UNKNOWN STANZA" s
	return []


@@ 1120,7 1158,7 @@ mapToBackend backendHost (JID { jidNode = Just node })
	where
	result = parseJID (localpart ++ s"@" ++ backendHost)
	localpart = strNode node
mapToBackend _ _ = Nothing
mapToBackend backendHost (JID { jidNode = Nothing }) = parseJID backendHost

normalizeTel fullTel
	| Just ('+',e164) <- T.uncons fullTel,