~singpolyma/cheogram

6ee74440bdaf8ad03f562eb4278a1f7d852703a2 — Stephen Paul Weber 5 years ago 75af390
Pass through presence at all
1 files changed, 67 insertions(+), 18 deletions(-)

M Main.hs
M Main.hs => Main.hs +67 -18
@@ 60,7 60,7 @@ getBody ns = listToMaybe . fmap (mconcat . elementText) . (isNamed (Name (fromSt

queryDisco to from = do
	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
	return $ [mkStanzaRec $ (emptyIQ IQGet) {
	return [mkStanzaRec $ (emptyIQ IQGet) {
		iqTo = Just to,
		iqFrom = Just from,
		iqID = uuid,


@@ 149,12 149,35 @@ cheogramAvailable from to =
			Element (s"{http://jabber.org/protocol/caps}c") [
				(s"{http://jabber.org/protocol/caps}hash", [ContentText $ fromString "sha-1"]),
				(s"{http://jabber.org/protocol/caps}node", [ContentText $ fromString "xmpp:cheogram.com"]),
				-- gateway/sms//Cheogram SMS Gateway<jabber:iq:gateway<jabber:iq:register<urn:xmpp:ping<
				(s"{http://jabber.org/protocol/caps}ver", [ContentText $ fromString "4/LEvjGRsHBQRu9D+1NwytYdFUY="])
				-- gateway/sms//Cheogram<jabber:iq:gateway<jabber:iq:register<urn:xmpp:ping<
				(s"{http://jabber.org/protocol/caps}ver", [ContentText $ fromString "QEUi902gYi/nDHreMi6vQ6h9HW0="])
			] []
		]
	}

telDiscoFeatures = [
		"http://jabber.org/protocol/muc",
		"jabber:x:conference",
		"urn:xmpp:ping"
	]

telAvailable from to disco =
	(emptyPresence PresenceAvailable) {
		presenceTo = Just to,
		presenceFrom = Just from,
		presencePayloads = []
	}

routeDiscoOrPresenceReply db componentJid from to smsJid = 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
		_ -> return [mkStanzaRec $ telAvailable to from []]
	where
	maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/query-then-send-presence"

componentMessage _ componentJid (m@Message { messageType = MessageError }) _ _ _ smsJid body = do
	log "MESSAGE ERROR"  m
	return [mkStanzaRec $ m { messageTo = Just smsJid, messageFrom = Just componentJid }]


@@ 518,7 541,7 @@ componentStanza db (Just smsJid) toRoomPresences toRejoinManager toJoinPartDebou
		log "JOIN PART ROOM" (from, to, typ, existingRoom, payloads)
		handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads (typ == PresenceAvailable)
componentStanza _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
	log "SUBSCRIBE" (from, to)
	log "SUBSCRIBE GATEWAY" (from, to)
	return [
			mkStanzaRec $ (emptyPresence PresenceSubscribed) {
				presenceTo = Just from,


@@ 530,9 553,25 @@ componentStanza _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = Prese
			},
			mkStanzaRec $ cheogramAvailable to from
		]
componentStanza db (Just smsJid) _ _ _ _ componentJid (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Just _ } })) = do
	log "SUBSCRIBE TEL" (from, to)
	stanzas <- routeDiscoOrPresenceReply db componentJid from to smsJid
	return $ [
			mkStanzaRec $ (emptyPresence PresenceSubscribed) {
				presenceTo = Just from,
				presenceFrom = Just to
			},
			mkStanzaRec $ (emptyPresence PresenceSubscribe) {
				presenceTo = Just from,
				presenceFrom = Just to
			}
		] ++ stanzas
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
	routeDiscoOrPresenceReply db componentJid from to smsJid
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")) ||
	  fmap strResource (jidResource to) == Just ConfigureDirectMessageRoute.nodeName = do


@@ 560,7 599,7 @@ componentStanza _ _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqFro
					NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}identity") [
						(fromString "{http://jabber.org/protocol/disco#info}category", [ContentText $ fromString "gateway"]),
						(fromString "{http://jabber.org/protocol/disco#info}type", [ContentText $ fromString "sms"]),
						(fromString "{http://jabber.org/protocol/disco#info}name", [ContentText $ fromString "Cheogram SMS Gateway"])
						(fromString "{http://jabber.org/protocol/disco#info}name", [ContentText $ fromString "Cheogram"])
					] [],
					NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [
						(fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "jabber:iq:gateway"])


@@ 599,18 638,18 @@ componentStanza _ _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just fr
			iqTo = Just from,
			iqFrom = Just to,
			iqID = id,
			iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") []
			iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] $
				[
					NodeElement $ Element (s"{http://jabber.org/protocol/disco#info}identity") [
						(s"{http://jabber.org/protocol/disco#info}category", [ContentText $ s"client"]),
						(s"{http://jabber.org/protocol/disco#info}type", [ContentText $ s"sms"]),
						(s"{http://jabber.org/protocol/disco#info}name", [ContentText $ s"Cheogram"])
					] []
				] ++ map (\var ->
					NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [
						(fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "http://jabber.org/protocol/muc"])
					] [],
					NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [
						(fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "jabber:x:conference"])
					] [],
					NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [
						(fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "urn:xmpp:ping"])
					] []
				]
				) telDiscoFeatures
		}]
componentStanza _ _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQSet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p }))
	| [query] <- isNamed (fromString "{jabber:iq:gateway}query") p,


@@ 691,7 730,7 @@ componentStanza _ (Just smsJid) _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType
componentStanza _ _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p }))
	| [query] <- isNamed (fromString "{http://jabber.org/protocol/muc#owner}query") p,
	  [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query = do
		log "DISCO RESULT" (from, to, p)
		log "MUC DISCO RESULT" (from, to, p)
		uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
		let fullid = if fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id then "CHEOGRAMCREATE%" <> uuid else uuid
		return [mkStanzaRec $ (emptyIQ IQSet) {


@@ 713,9 752,18 @@ componentStanza _ (Just smsJid) _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType
		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 { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p }))
	| Just _ <- strNode <$> jidNode to,
	  [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
componentStanza db _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to@(JID { jidNode = Just toNode }), iqFrom = Just from, iqPayload = Just p }))
	| fmap strResource (jidResource to) == Just (s"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
		log "DISCO RESULT, NOW SEND PRESENCE" (from, to, routeFrom, routeTo)
		return [
				mkStanzaRec $ telAvailable routeFrom routeTo $ 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
		log "DISCO RESULT" (from, to, p)
		let vars = mapMaybe (attributeText (fromString "var")) $
			isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query


@@ 791,7 839,8 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC
								mapM_ sendToComponent =<< processSMS db componentJid conferenceServers from cheoJid txt
						_ -> log "backend no match" stanza
			(Just from, Just to, Nothing, Just localpart)
				| fmap strResource (jidResource to) /= Just ConfigureDirectMessageRoute.nodeName -> do
				| fmap strResource (jidResource to) /= Just ConfigureDirectMessageRoute.nodeName,
				  fmap strResource (jidResource to) /= Just (s"query-then-send-presence") -> 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