From 820ebd38117d55707b9029d75ba77b2f5eba50bf Mon Sep 17 00:00:00 2001
From: Stephen Paul Weber <singpolyma@singpolyma.net>
Date: Sun, 26 Feb 2017 21:34:11 -0500
Subject: [PATCH] Send delivery receipts

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

Closes #24
---
 Main.hs | 37 ++++++++++++++++++++++++++++++++++---
 1 file changed, 34 insertions(+), 3 deletions(-)

diff --git a/Main.hs b/Main.hs
index b373131..33549af 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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,
-- 
2.38.5