~singpolyma/cheogram

820ebd38117d55707b9029d75ba77b2f5eba50bf — Stephen Paul Weber 5 years ago 14c6b2e
Send delivery receipts

If upstream gateway doesn't generate them, then the best we can do is
generate them ourselves.

Closes #24
1 files changed, 34 insertions(+), 3 deletions(-)

M Main.hs
M Main.hs => Main.hs +34 -3
@@ 162,7 162,8 @@ cheogramAvailable from to =
telDiscoFeatures = [
		s"http://jabber.org/protocol/muc",
		s"jabber:x:conference",
		s"urn:xmpp:ping"
		s"urn:xmpp:ping",
		s"urn:xmpp:receipts"
	]

telCapsStr extraVars =


@@ 212,6 213,16 @@ routeDiscoOrReply db componentJid from smsJid resource reply = do
	where
	maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/" ++ (fromString resource)

deliveryReceipt id from to =
	(emptyMessage MessageNormal) {
		messageFrom = Just from,
		messageTo = Just to,
		messagePayloads = [
			Element (s"{urn:xmpp:receipts}received")
				[(s"{urn:xmpp:receipts}id", [ContentText id])] []
		]
	}

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


@@ 247,11 258,17 @@ componentMessage _ componentJid (m@Message { messageType = MessageGroupChat }) e
		return []
	where
	txt = mconcat [fromString "(", fromMaybe (fromString "nonick") resourceFrom, fromString ") ", body]
componentMessage db componentJid m@(Message { messageFrom = Just from }) existingRoom bareFrom resourceFrom smsJid (Just body) = do
componentMessage db componentJid m@(Message { messageFrom = Just from, messageTo = Just to }) existingRoom bareFrom resourceFrom smsJid (Just body) = do
	log "WHISPER" (from, smsJid, body)

	ack <- case isNamed (fromString "{urn:xmpp:receipts}request") =<< messagePayloads m of
		(_:_) ->
			routeDiscoOrReply db componentJid from smsJid ("CHEOGRAM%query-then-send-ack%" ++ extra)
				(deliveryReceipt (fromMaybe mempty $ messageID m) to from)
		[] -> return []

	maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
	case (fmap fromString maybeRoute, parseJID $ escapeJid bareFrom ++ s"@" ++ formatJID componentJid ++ resourceSuffix) of
	fmap (++ack) $ case (fmap fromString maybeRoute, parseJID $ escapeJid bareFrom ++ s"@" ++ formatJID componentJid ++ resourceSuffix) of
		(Just route, Just routeFrom) -> do
			log "WHISPER ROUTE" route
			return [mkStanzaRec $ m {


@@ 263,6 280,7 @@ componentMessage db componentJid m@(Message { messageFrom = Just from }) existin
			let txt = mconcat [fromString "(", nick, fromString " whispers) ", body]
			return [mkStanzaRec $ mkSMS componentJid smsJid txt]
	where
	extra = T.unpack $ escapeJid $ T.pack $ show (fromMaybe mempty (messageID m), fromMaybe mempty resourceFrom)
	resourceSuffix = maybe mempty (s"/"++) resourceFrom
componentMessage _ _ m _ _ _ _ _ = do
	log "UNKNOWN MESSAGE" m


@@ 775,6 793,19 @@ componentStanza _ (Just smsJid) _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType
			forM (parseJID $ bareTxt to <> fromString "/create") $
				queryDisco from
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,
	  [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) =
		let features = mapMaybe (attributeText (fromString "var")) $ isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query in
		if (s"urn:xmpp:receipts") `elem` features then do
			log "DISCO RESULT, DO NOT SEND ACK" (from, to, features)
			return []
		else do
			log "DISCO RESULT, NOW SEND ACK" (from, to, routeFrom, routeTo, features)
			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,