~singpolyma/cheogram

da853b0b9982dc63290066f939ef4b85c5dec839 — Stephen Paul Weber 6 months ago 45718aa
Support passing through messages from alphanumeric senders

Some countries support these one-way SMS senders that come from ascii
alphanum+space senders.  All known SGX pass those through raw as the localpart,
so why not just allow them to and fix it up in Cheogram, since that's our whole
job is to make the SGX author's life easier.

Converts to Base10 (https://wiki.soprani.ca/TextEncodingBase10) and appends a
suitable phone-context.  Don't need to specially handle replies since these are
one-way senders anyway so any reply attempt will fail.  Adds the original
localpart as a nickname so that clients can show it rather than the Base10 gunk.
2 files changed, 19 insertions(+), 0 deletions(-)

M Main.hs
M Util.hs
M Main.hs => Main.hs +9 -0
@@ 1373,6 1373,15 @@ component db redis pushStatsd backendHost did maybeAvatar cacheOOB sendIQ iqRece
					case (maybeRoute, mapToComponent from) of
						(Just route, Just componentFrom) | route == strDomain (jidDomain from) ->
							(sendToComponent . receivedStanza) =<< mapReceivedMessageM (UIO.lift . cacheOOB) (receivedStanzaFromTo componentFrom routeTo stanza)
						(Just route, _) -- Alphanumeric senders
							| route == strDomain (jidDomain from),
							  Just localpart <- strNode <$> jidNode from,
							  Nothing <- T.find (\c -> not ((isAlphaNum c || c == ' ') && isAscii c)) localpart ->
								let
									localpart' = T.concatMap (\c -> tshow (ord c - 30)) localpart ++ s";phone-context=alphanumeric.phone-context.soprani.ca"
									Just componentFrom = parseJID (localpart' ++ s"@" ++ formatJID componentJid)
								in
								(sendToComponent . receivedStanza) =<< mapReceivedMessageM (fmap (addNickname localpart) . UIO.lift . cacheOOB) (receivedStanzaFromTo componentFrom routeTo stanza)
						_ | Just jid <- (`telToJid` formatJID componentJid) =<< strNode <$> jidNode to -> do
							sendToComponent $ stanzaError stanza $
								Element (fromString "{jabber:component:accept}error")

M Util.hs => Util.hs +10 -0
@@ 247,6 247,16 @@ forkFinallyXMPP kid handler = do
mkElement :: XML.Name -> Text -> XML.Element
mkElement name txt = XML.Element name [] [XML.NodeContent $ XML.ContentText txt]

nickname :: Text -> XML.Element
nickname nick = XML.Element (s"{http://jabber.org/protocol/nick}nick") [] [
		XML.NodeContent $ XML.ContentText nick
	]

addNickname :: Text -> XMPP.Message -> XMPP.Message
addNickname nick m@(XMPP.Message { XMPP.messagePayloads = p }) = m {
		XMPP.messagePayloads = (nickname nick) : p
	}

mapReceivedMessageM :: (Applicative f) =>
	  (XMPP.Message -> f XMPP.Message)
	-> XMPP.ReceivedStanza