~singpolyma/cheogram

347574e6ba4c751b779319e148b362cb8bfdd241 — Stephen Paul Weber 2 months ago a67c358
First draft of grouptext porcelein

Works, but does not pass through anything yet if target supports it, and may be
otherwise a bit rough.
1 files changed, 84 insertions(+), 10 deletions(-)

M Main.hs
M Main.hs => Main.hs +84 -10
@@ 8,15 8,16 @@ import Control.Concurrent.STM
import Data.Foldable (forM_, mapM_, toList)
import Data.Traversable (forM, mapM)
import System.Environment (getArgs)
import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe)
import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe, headZ)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Network (PortID(PortNumber))
import Network.URI (parseURI, uriPath)
import System.Random (Random(randomR), getStdRandom)
import System.Random.Shuffle (shuffleM)
import Data.Digest.Pure.SHA (sha1, bytestringDigest)

import "monads-tf" Control.Monad.Error (catchError) -- ick
import Data.XML.Types (Element(..), Node(NodeContent, NodeElement), Name(Name), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText)
import Data.XML.Types (Element(..), Node(NodeContent, NodeElement), Name(Name), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText, hasAttribute)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
import qualified Data.Text.Encoding as T


@@ 672,6 673,10 @@ handleRegister _ _ iq _ = do
	return []

componentStanza db _ _ _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just (JID { jidNode = Nothing }), messageFrom = Just from}))
	| Just reply <- groupTextPorcelein (formatJID componentJid) m =
		-- TODO: only when from direct message route
		-- TODO: only if target does not understand stanza addressing
		return [mkStanzaRec reply]
	| Just _ <- getBody "jabber:component:accept" m = 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")
		]


@@ 735,12 740,30 @@ componentStanza db (Just smsJid) _ _ _ _ _ componentJid (ReceivedPresence (Prese
				presenceFrom = Just to
			}
		] ++ stanzas
componentStanza db Nothing _ _ _ _ _ componentJid (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Just node } }))
	| Just multipleTo <- mapM localpartToURI (T.split (==',') $ strNode node) = do
	log "SUBSCRIBE GROUPTEXT PORCELEIN" (from, multipleTo)
	return $ [
			mkStanzaRec $ (emptyPresence PresenceSubscribed) {
				presenceTo = Just from,
				presenceFrom = Just to
			},
			mkStanzaRec $ (emptyPresence PresenceSubscribe) {
				presenceTo = Just from,
				presenceFrom = Just to
			},
			mkStanzaRec $ telAvailable to from []
		]
componentStanza _ _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
	log "RESPOND TO PROBES" (from, to)
	return [mkStanzaRec $ cheogramAvailable to from]
componentStanza db (Just smsJid) _ _ _ _ _ componentJid (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Just _ } })) = do
	log "RESPOND TO TEL PROBES" smsJid
	routeDiscoOrReply db componentJid from smsJid "CHEOGRAM%query-then-send-presence" Nothing $ telAvailable to from []
componentStanza db _ _ _ _ _ _ componentJid (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Just node } }))
	| Just multipleTo <- mapM localpartToURI (T.split (==',') $ strNode node) = do
	log "RESPOND TO GROUPCHAT PORCELEIN PROBES" multipleTo
	return $ [mkStanzaRec $ telAvailable to from []]
componentStanza _ _ registrationJids _ _ _ processDirectMessageRouteConfig componentJid (ReceivedIQ (IQ { iqType = IQSet, iqTo = Just to, iqFrom = Just from, iqID = Just id, iqPayload = Just p }))
	| jidNode to == Nothing,
	  [iqEl] <- isNamed (s"{jabber:client}iq") =<< elementChildren =<< isNamed (s"{urn:xmpp:forward:0}forwarded") p,


@@ 1120,14 1143,31 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC
								tcPut db cheoJid "owners" (show $ (T.unpack $ bareTxt owner) : owners)

							_ -> log "NO TOKEN FOUND, or mismatch" maybeToken
			(Just from, Just to, Nothing, _, _) |
				Just multipleTo <- mapM localpartToURI (T.split (==',') $ fromMaybe mempty $ fmap strNode $ jidNode to),
				ReceivedMessage m <- stanza,
				Just backendJid <- parseJID backendHost ->
					log "TO MULTICAST PORCELEIN" to >>
					let m' = m { messagePayloads = messagePayloads m ++ [
						Element (s"{http://jabber.org/protocol/address}addresses") [] $ map (\oneto ->
							NodeElement $ Element (s"{http://jabber.org/protocol/address}address") [
								(s"{http://jabber.org/protocol/address}type", [ContentText $ s"to"]),
								(s"{http://jabber.org/protocol/address}uri", [ContentText oneto])
							] []
						) multipleTo
					] } in
					-- TODO: should check if backend supports XEP-0033
					-- TODO: fallback for no-backend case should work
					mapM_ sendToComponent =<< componentMessage db componentJid m' Nothing (bareTxt from) (strResource <$> jidResource from) backendJid (getBody "jabber:component:accept" m')
			(Just from, Just to, Nothing, Just localpart, _)
				| fmap (((s"CHEOGRAM%") `T.isPrefixOf`) . strResource) (jidResource to) /= Just True -> do
				| Nothing <- mapM localpartToURI (T.split (==',') $ fromMaybe mempty $ fmap strNode $ jidNode to),
				  fmap (((s"CHEOGRAM%") `T.isPrefixOf`) . strResource) (jidResource to) /= Just True -> do
					let toResourceSuffix = maybe mempty (s"/"++) (strResource <$> jidResource to)
					maybeRoute <- TC.runTCM $ TC.get db (T.unpack (unescapeJid localpart) ++ "\0direct-message-route")
					case (fmap fromString maybeRoute, parseJID (unescapeJid localpart ++ toResourceSuffix), mapToComponent from) of
						(Just route, Just routeTo, Just componentFrom) | route == strDomain (jidDomain from) -> do
							log "FROM DIRECT ROUTE" stanza
							sendToComponent $ receivedStanzaFromTo componentFrom routeTo stanza
							sendToComponent $ mkStanzaRec $ receivedStanza $ receivedStanzaFromTo componentFrom routeTo stanza
						_ | Just jid <- (`telToJid` formatJID componentJid) =<< strNode <$> jidNode to -> do
							log "MESSAGE INVALID JID" stanza
							sendToComponent $ stanzaError stanza $


@@ 1174,15 1214,15 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC
			iqPayload = Just errorPayload
		}

	receivedStanzaFromTo from to (ReceivedMessage m) = mkStanzaRec $ m {
	receivedStanzaFromTo from to (ReceivedMessage m) = ReceivedMessage $ m {
			messageFrom = Just from,
			messageTo = Just to
		}
	receivedStanzaFromTo from to (ReceivedPresence p) = mkStanzaRec $ p {
	receivedStanzaFromTo from to (ReceivedPresence p) = ReceivedPresence $ p {
			presenceFrom = Just from,
			presenceTo = Just to
		}
	receivedStanzaFromTo from to (ReceivedIQ iq) = mkStanzaRec $ iq {
	receivedStanzaFromTo from to (ReceivedIQ iq) = ReceivedIQ $ iq {
			iqFrom = Just from,
			iqTo = Just to
		}


@@ 1191,15 1231,49 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC
	receivedStanza (ReceivedPresence p) = mkStanzaRec p
	receivedStanza (ReceivedIQ iq) = mkStanzaRec iq

mapToBackend backendHost (JID { jidNode = Just node })
groupTextPorcelein :: Text -> Message -> Maybe Message
groupTextPorcelein host m@(Message { messagePayloads = p, messageFrom = Just from })
	| [addresses] <- isNamed (s"{http://jabber.org/protocol/address}addresses") =<< p,
	  [body] <- isNamed (s"{jabber:component:accept}body") =<< p,
	  (jids, uris) <- partition (maybe False (const True) . headZ . hasAttribute (s"jid"))
			(hasAttributeText (s"type") (`elem` [s"to", s"cc"]) =<<
			isNamed (s"{http://jabber.org/protocol/address}address") =<< elementChildren addresses),
	  [Just to] <- (proxiedJidToReal <=< parseJID <=< attributeText (s"jid")) <$> jids,
	  Just fromTel <- strNode <$> jidNode from,
	  Just tels <- fmap (textToString fromTel:) $ mapM (fmap uriPath . parseURI . textToString <=< attributeText (s"uri")) uris =
		Just $ m {
			messageTo = Just to,
			messageFrom = parseJID (fromString (intercalate "," (sort tels)) ++ (s"@") ++ host),
			messagePayloads = body { elementNodes = (NodeContent $ ContentText $ s"(") : (NodeContent $ ContentText fromTel) : (NodeContent $ ContentText $ s") ") : elementNodes body } :
				filter (`notElem` [addresses, body]) p
		}
groupTextPorcelein _ _ = Nothing

proxiedJidToReal :: JID -> Maybe JID
proxiedJidToReal jid =
	parseJID =<< fmap (maybe id (\r -> (++ (s"/" ++ r))) resource) bare
	where
	resource = strResource <$> jidResource jid
	bare = unescapeJid . strNode <$> jidNode jid

mapToBackend backendHost (JID { jidNode = Just node }) = mapLocalpartToBackend backendHost (strNode node)
mapToBackend backendHost (JID { jidNode = Nothing }) = parseJID backendHost

mapLocalpartToBackend backendHost localpart
	| Just ('+', tel) <- T.uncons localpart,
	  T.all isDigit tel = result
	| Just _ <- parsePhoneContext localpart = result
	| otherwise = Nothing
	where
	result = parseJID (localpart ++ s"@" ++ backendHost)
	localpart = strNode node
mapToBackend backendHost (JID { jidNode = Nothing }) = parseJID backendHost

localpartToURI localpart
	| Just ('+', tel) <- T.uncons localpart,
	  T.all isDigit tel = result
	| Just _ <- parsePhoneContext localpart = result
	| otherwise = Nothing
	where
	result = Just (s"sms:" ++ localpart)

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