~singpolyma/cheogram-smtp

9efc45dd3ae9165f22757aafbe193ef515ecea1e — Stephen Paul Weber 2 years ago b822663
Reconstruct References from In-Reply-To if the former is missing
2 files changed, 68 insertions(+), 4 deletions(-)

M Email.hs
M test/EmailTest.hs
M Email.hs => Email.hs +12 -4
@@ 109,7 109,7 @@ emailToOriginID email = fmap originID $ hush . MIME.parse messageID =<<
		[(s"{urn:xmpp:sid:0}id", [XML.ContentText msgid])] []

extractThreadFromRef :: Text -> Atto.Parser Text
extractThreadFromRef domain = fmap equalsDecode $
extractThreadFromRef domain = mfilter (/= s"\0") $ fmap equalsDecode $
	Atto.satisfy (==0x3C) *>
	Atto.skipWhile (`notElem`[0x2E,0x3E,0x20]) *>
	Atto.satisfy (==0x2E) *>


@@ 135,6 135,14 @@ limitReferencesLength refs = C8.unwords $ limit (C8.words refs)
	limit (x:xs) = x : drop (length xs - 4) xs
	limit [] = []

referencesFromInReplyTo :: Text -> MIME.MIMEMessage -> Maybe ByteString
referencesFromInReplyTo domain email =
	maybe replyto (\refs -> fmap ((refs ++ s" ") ++) replyto) extractedRefs
	where
	extractedRefs = fmap encodeUtf8 $ T.stripPrefix (s"References: ") =<<
		(hush . MIME.parse (extractThreadFromRef domain) =<< replyto)
	replyto = firstOf (MIME.headers . MIME.header (s"in-reply-to")) email

emailToThread :: Text -> MIME.MIMEMessage -> Maybe XML.Element
emailToThread domain email = thread <&> \threadID ->
	XML.Element (s"{jabber:component:accept}thread")


@@ 146,13 154,13 @@ emailToThread domain email = thread <&> \threadID ->
		fmap (
			(,) (s"{jabber:component:accept}parent") .
			(:[]) . XML.ContentText
		) $
		mfilter (/= s"\0")
		)
		(hush . MIME.parse (extractThreadFromRefs domain) =<< refs)
	thread = fmap (s"References: "++) $
		((\x y -> x ++ s" " ++ y) <$> refs <*> msgid) <|> msgid
	msgid = firstOf (MIME.headers . MIME.header (s"message-id")) email
	refs = firstOf (MIME.headers . MIME.header (s"references")) email
	refs = firstOf (MIME.headers . MIME.header (s"references")) email <|>
		referencesFromInReplyTo domain email

emailSubject :: MIME.MIMEMessage -> Maybe Text
emailSubject email = MIME.decodeEncodedWords MIME.defaultCharsets <$>

M test/EmailTest.hs => test/EmailTest.hs +56 -0
@@ 302,6 302,62 @@ unit_emailToStanzaDeepReply =
	\\n\
	\Hello\n"

unit_emailToStanzaDeepInReplyTo:: IO ()
unit_emailToStanzaDeepInReplyTo =
	show (emailToStanza (s"gateway.example.com") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageNormal) {
		XMPP.messageFrom =
			XMPP.parseJID $ s"f\\40example.com@gateway.example.com",
		XMPP.messagePayloads = [
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element (s"{jabber:component:accept}subject") [] [
				XML.NodeContent $ XML.ContentText $ s"subject"
			],
			XML.Element (s"{urn:xmpp:sid:0}origin-id") [(
				s"{urn:xmpp:sid:0}id",
				[XML.ContentText $ s"abc@example.com"]
			)] [],
			XML.Element (s"{jabber:component:accept}thread") [(
				s"{jabber:component:accept}parent",
				[XML.ContentText $ s"References: <1583335391.\
					\7d84bbbf-4dd8-42f7-81cc-d7f4ffa06609.\
					\exBUAYVLbCAwUgAUpONVhfirfwVfAUZf\
					\@gateway.example.com>\
					\ <20200304152333.GA4768@example.com>"
				]
			)] [
				XML.NodeContent $ XML.ContentText $
				s"References: <1583335391.7d84bbbf-4dd8-42f7-\
					\81cc-d7f4ffa06609.exBUAYVLbCAwUgAUpON\
					\VhfirfwVfAUZf@gateway.example.com>\
					\ <20200304152333.GA4768@example.com>\
					\ <1583335474.cdc32108-582b-4256-a5b0-\
					\09c4d17af3f8.References=3A=20=3C15833\
					\35391=2E7d84bbbf-4dd8-42f7-81cc-d7f4f\
					\fa06609=2EexBUAYVLbCAwUgAUpONVhfirfwV\
					\fAUZf=40gateway=2Eexample=2Ecom\
					\=3E=20=3C20200304152333=2EGA4768=40\
					\example=2Ecom=3E@gateway.example.com>\
					\ <abc@example.com>"
			]
		]
	}
	where
	Right message = MIME.parse (MIME.message MIME.mime) email
	email = encodeUtf8 $ s"To: to@example.com\n\
	\From: f@example.com\n\
	\Subject: subject\n\
	\Message-ID: <abc@example.com>\n\
	\In-Reply-To: <1583335474.cdc32108-582b-4256-a5b0-09c4d17af3f8.\
		\References=3A=20=3C1583335391=2E7d84bbbf-4dd8-42f7-81cc-\
		\d7f4ffa06609=2EexBUAYVLbCAwUgAUpONVhfirfwVfAUZf\
		\=40gateway=2Eexample=2Ecom=3E=20=3C20200304152333\
		\=2EGA4768=40example=2Ecom=3E@gateway.example.com>\n\
	\\n\
	\Hello\n"

unit_messageToEmailChat :: IO ()
unit_messageToEmailChat =