~singpolyma/cheogram-smtp: Implement Message-ID and References headers

3 files changed, 370 insertions(+), 26 deletions(-)

M Email.hs
M incoming-email.hs
M test/EmailTest.hs

M Email.hs => Email.hs +91 -13

@@ 3,10 3,13 @@ module Email where
 import BasicPrelude
 import Prelude ()
 import Data.Char                                 (isAscii, isAlphaNum)
-import Control.Error                             (headZ, hush)
+import Data.Functor                              ((<&>))
+import Control.Error                             (headZ, lastZ, justZ, hush)
 import Data.Time.Clock                           (UTCTime)
+import Data.Time.Format                          (formatTime, defaultTimeLocale)
 import Control.Lens 
 	(Const, Leftmost, filtered, firstOf, view, _Right, set, at)
+import qualified Data.ByteString.Char8           as C8
 import qualified Data.Text                       as T
 import qualified Data.Attoparsec.ByteString.Lazy as Atto
 import qualified Data.MIME                       as MIME


@@ 57,9 60,7 @@ plainTextBody = MIME.entities . filtered isTextPlain . getEmailBody
 
 mailboxNode :: MIME.Mailbox -> Text
 mailboxNode (MIME.Mailbox _ (MIME.AddrSpec local _)) =
-	fromString $ URI.unEscapeString $
-	map (\c -> if c == '=' then '%' else c) $
-	textToString $ decodeUtf8 local
+	equalsDecode local
 
 mailboxToJID :: Text -> MIME.Mailbox -> Maybe XMPP.JID
 mailboxToJID domain (MIME.Mailbox _ addrspec) =


@@ 73,11 74,19 @@ unescapedInEmailLocalpart c = isAscii c &&
 	(isAlphaNum c || c `elem` "#$&'*+-/?^_`{|}~")
 
 jidToLocalpart :: XMPP.JID -> ByteString
-jidToLocalpart jid = encodeUtf8 $ fromString $
-	map (\c -> if c == '%' then '=' else c) $
-	URI.escapeURIString unescapedInEmailLocalpart bareStr
-	where
-	bareStr = textToString $ bareTxt jid
+jidToLocalpart = encodeUtf8 . fromString . equalsEncode . bareTxt
+
+equalsEncode :: Text -> String
+equalsEncode =
+	map (\c -> if c == '%' then '=' else c) .
+	URI.escapeURIString unescapedInEmailLocalpart .
+	textToString
+
+equalsDecode :: ByteString -> Text
+equalsDecode =
+	fromString . URI.unEscapeString .
+	map (\c -> if c == '=' then '%' else c) .
+	textToString . decodeUtf8
 
 jidToMailbox :: XMPP.JID -> MIME.Domain -> MIME.Mailbox
 jidToMailbox jid domain = MIME.Mailbox (Just $ bareTxt jid) $


@@ 98,19 107,65 @@ emailToOriginID email = fmap originID $ hush . MIME.parse messageID =<<
 	originID msgid = XML.Element (s"{urn:xmpp:sid:0}origin-id")
 		[(s"{urn:xmpp:sid:0}id", [XML.ContentText msgid])] []
 
+extractThreadFromRef :: Text -> Atto.Parser Text
+extractThreadFromRef domain = fmap equalsDecode $
+	Atto.satisfy (==0x3C) *>
+	Atto.skipWhile (`notElem`[0x2E,0x3E,0x20]) *>
+	Atto.satisfy (==0x2E) *>
+	Atto.skipWhile (`notElem`[0x2E,0x3E,0x20]) *>
+	Atto.satisfy (==0x2E) *>
+	Atto.takeTill (`elem`[0x40,0x3E,0x20]) <*
+	Atto.satisfy (==0x40) <*
+	Atto.string (encodeUtf8 domain) <*
+	Atto.satisfy (==0x3E)
+
+extractThreadFromRefs :: Text -> Atto.Parser Text
+extractThreadFromRefs domain =
+	justZ =<< lastZ =<<
+	Atto.sepBy
+		((Just <$> extractThreadFromRef domain) <|> skipWord)
+		(Atto.many1 $ Atto.satisfy (==0x20))
+	where
+	skipWord = Atto.skipWhile (/=0x20) *> pure Nothing
+
+limitReferencesLength :: ByteString -> ByteString
+limitReferencesLength refs = C8.unwords $ limit (C8.words refs)
+	where
+	limit (x:xs) = x : drop (length xs - 4) xs
+	limit [] = []
+
+emailToThread :: Text -> MIME.MIMEMessage -> Maybe XML.Element
+emailToThread domain email = thread <&> \threadID ->
+	XML.Element (s"{jabber:component:accept}thread")
+	parent
+	[XML.NodeContent $ XML.ContentText $ decodeUtf8 threadID]
+	where
+	parent =
+		maybeToList $
+		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
+
 emailToStanza ::
-	   (MIME.Mailbox -> Maybe XMPP.JID)
+	   Text
 	-> MIME.MIMEMessage
 	-> XMPP.Message
-emailToStanza toJid email =
+emailToStanza domain email =
 	(XMPP.emptyMessage $ emailToMessageType email) {
-		XMPP.messageFrom = toJid fromMailbox,
+		XMPP.messageFrom = mailboxToJID domain fromMailbox,
 		XMPP.messagePayloads = [
 			XML.Element (s"{jabber:component:accept}subject") []
 				[XML.NodeContent $ XML.ContentText subject],
 			XML.Element (s"{jabber:component:accept}body") []
 				[XML.NodeContent $ XML.ContentText textBody]
-		] ++ nick ++ mid
+		] ++ nick ++ mid ++ maybeToList (emailToThread domain email)
 	}
 	where
 	mid = maybeToList $ emailToOriginID email


@@ 134,6 189,25 @@ typeHeaders XMPP.Message { XMPP.messageType = XMPP.MessageChat } =
 	set (MIME.headers . at (s"Chat-Version")) (Just $ s"1.0")
 typeHeaders _ = id
 
+mkMessageID :: MIME.Domain -> UTCTime -> XMPP.Message -> ByteString
+mkMessageID domain now message = ((s"<" ++) . (++ s">")) $
+	MIME.renderAddressSpec $ flip MIME.AddrSpec domain
+	(fromString $ time ++ "." ++ sid ++ "." ++ thread)
+	where
+	sid = fromMaybe "=00" $ equalsEncode <$> XMPP.stanzaID message
+	thread =
+		fromMaybe "=00" $
+		fmap (equalsEncode . mconcat . XML.elementText) $
+		child (s"{jabber:component:accept}thread") message
+	time = formatTime defaultTimeLocale "%s" now
+
+mkReferences :: XMPP.Message -> Maybe ByteString
+mkReferences =
+	fmap (limitReferencesLength . encodeUtf8) .
+	(T.stripPrefix (s"References: ") =<<) .
+	fmap (mconcat . XML.elementText) .
+	child (s"{jabber:component:accept}thread")
+
 messageToEmail ::
 	   MIME.Domain
 	-> UTCTime


@@ 145,6 219,8 @@ messageToEmail fromDomain now message@XMPP.Message {
 	} | Just bodyTxt <- getBody message,
 	    Right toAddress <- parsedToNode =
 		Just (fromMailbox,
+			set (MIME.headers . at (s"Message-ID")) (Just mid) $
+			set (MIME.headers . at (s"References")) refs $
 			typeHeaders message $
 			set (MIME.headerTo MIME.defaultCharsets) [toAddress] $
 			setFrom $


@@ 154,6 230,8 @@ messageToEmail fromDomain now message@XMPP.Message {
 			MIME.createTextPlainMessage bodyTxt
 		)
 	where
+	mid = mkMessageID fromDomain now message
+	refs = mkReferences message
 	jidHeader = Just $ MIME.encodeEncodedWords (bareTxt from)
 	dateHeader = fromMaybe now $ parseXMPPTime =<<
 		XML.attributeText (s"{urn:xmpp:delay}stamp") =<<

M incoming-email.hs => incoming-email.hs +1 -1

@@ 41,7 41,7 @@ main = do
 	input <- LByteString.getContents
 	let Right email = MIME.parse messageOptionalMboxFrom input
 	let messages = recipientJids <&> \recipientJid ->
-		(emailToStanza (mailboxToJID domain) email) {
+		(emailToStanza domain email) {
 			XMPP.messageTo = Just recipientJid
 		}

M test/EmailTest.hs => test/EmailTest.hs +278 -12

@@ 4,6 4,7 @@ import Prelude ()
 import BasicPrelude
 import Test.Tasty.HUnit
 import Test.QuickCheck.Instances ()
+import qualified Data.Time.Format as Time
 import qualified Data.MIME as MIME
 import qualified Data.XML.Types as XML
 import qualified Network.Protocol.XMPP as XMPP


@@ 39,7 40,7 @@ unit_mailboxToJID =
 
 unit_emailToStanzaSimple :: IO ()
 unit_emailToStanzaSimple =
-	show (emailToStanza (mailboxToJID $ s"gateway.example.com") message)
+	show (emailToStanza (s"gateway.example.com") message)
 	@?=
 	show (XMPP.emptyMessage XMPP.MessageNormal) {
 		XMPP.messageFrom =


@@ 58,7 59,11 @@ unit_emailToStanzaSimple =
 			XML.Element (s"{urn:xmpp:sid:0}origin-id") [(
 				s"{urn:xmpp:sid:0}id",
 				[XML.ContentText $ s"boop-id@ids.example.com"]
-			)] []
+			)] [],
+			XML.Element (s"{jabber:component:accept}thread") [] [
+				XML.NodeContent $ XML.ContentText $
+				s"References: <boop-id@ids.example.com>"
+			]
 		]
 	}
 	where


@@ 72,7 77,7 @@ unit_emailToStanzaSimple =
 
 unit_emailToStanzaChat :: IO ()
 unit_emailToStanzaChat =
-	show (emailToStanza (mailboxToJID $ s"gateway.example.com") message)
+	show (emailToStanza (s"gateway.example.com") message)
 	@?=
 	show (XMPP.emptyMessage XMPP.MessageChat) {
 		XMPP.messageFrom =


@@ 97,7 102,7 @@ unit_emailToStanzaChat =
 
 unit_emailToStanzUTF8Subject :: IO ()
 unit_emailToStanzUTF8Subject =
-	show (emailToStanza (mailboxToJID $ s"gateway.example.com") message)
+	show (emailToStanza (s"gateway.example.com") message)
 	@?=
 	show (XMPP.emptyMessage XMPP.MessageNormal) {
 		XMPP.messageFrom =


@@ 117,6 122,142 @@ unit_emailToStanzUTF8Subject =
 	\\n\
 	\Hello\n"
 
+unit_emailToStanzaReply :: IO ()
+unit_emailToStanzaReply =
+	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}subject") [] [
+				XML.NodeContent $ XML.ContentText $ s"subject"
+			],
+			XML.Element (s"{jabber:component:accept}body") [] [
+				XML.NodeContent $ XML.ContentText $ s"Hello\n"
+			],
+			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"athread"]
+			)] [
+				XML.NodeContent $ XML.ContentText $
+				s"References: \
+				\<123.456.athread@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\
+	\References: <123.456.athread@gateway.example.com>\n\
+	\\n\
+	\Hello\n"
+
+unit_emailToStanzaReplyNulThread :: IO ()
+unit_emailToStanzaReplyNulThread =
+	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}subject") [] [
+				XML.NodeContent $ XML.ContentText $ s"subject"
+			],
+			XML.Element (s"{jabber:component:accept}body") [] [
+				XML.NodeContent $ XML.ContentText $ s"Hello\n"
+			],
+			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") [] [
+				XML.NodeContent $ XML.ContentText $
+				s"References: \
+				\<123.456.=00@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\
+	\References: <123.456.=00@gateway.example.com>\n\
+	\\n\
+	\Hello\n"
+
+unit_emailToStanzaDeepReply:: IO ()
+unit_emailToStanzaDeepReply =
+	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}subject") [] [
+				XML.NodeContent $ XML.ContentText $ s"subject"
+			],
+			XML.Element (s"{jabber:component:accept}body") [] [
+				XML.NodeContent $ XML.ContentText $ s"Hello\n"
+			],
+			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\
+	\References: <1583335391.7d84bbbf-4dd8-42f7-81cc-d7f4ffa06609\
+		\.exBUAYVLbCAwUgAUpONVhfirfwVfAUZf@gateway.example.com>\n\
+		\ <20200304152333.GA4768@example.com>\n\
+		\ <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 =
 	fmap (MIME.renderMessage . snd) (


@@ 129,7 270,9 @@ unit_messageToEmailChat =
 	Just email
 	where
 	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
-	email = s"MIME-Version: 1.0\r\n\
+	timestamp = Time.formatTime Time.defaultTimeLocale "%s" date
+	email = s$"MIME-Version: 1.0\r\n\
+	\Message-ID: <" ++ timestamp ++ ".=00.=00@gateway.example.com>\r\n\
 	\Chat-Version: 1.0\r\n\
 	\To: t@example.com\r\n\
 	\From: =?utf-8?Q?=E4=B8=96@example.com?=\r\n\


@@ 147,7 290,7 @@ unit_messageToEmailChat =
 			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
 		XMPP.messageFrom = XMPP.parseJID $ s"世@example.com",
 		XMPP.messagePayloads = [
-			XML.Element (fromString "{jabber:component:accept}body")
+			XML.Element (s"{jabber:component:accept}body")
 			[] [
 				XML.NodeContent $ XML.ContentText $
 					s"世界\n.\n"


@@ 167,7 310,9 @@ unit_messageToEmailWithSubject =
 	Just email
 	where
 	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
-	email = s"MIME-Version: 1.0\r\n\
+	timestamp = Time.formatTime Time.defaultTimeLocale "%s" date
+	email = s$"MIME-Version: 1.0\r\n\
+	\Message-ID: <" ++ timestamp ++ ".123.=00@gateway.example.com>\r\n\
 	\To: t@example.com\r\n\
 	\From: \"f@example.com\" <f=40example=2Ecom@gateway.example.com>\r\n\
 	\Jabber-ID: f@example.com\r\n\


@@ 179,17 324,18 @@ unit_messageToEmailWithSubject =
 	\\r\n\
 	\5LiW55WMCi4K\r\n"
 	message = (XMPP.emptyMessage XMPP.MessageNormal) {
+		XMPP.messageID = Just $ s"123",
 		XMPP.messageTo =
 			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
 		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
 		XMPP.messagePayloads = [
 			XML.Element
-			(fromString "{jabber:component:accept}subject") [] [
+			(s"{jabber:component:accept}subject") [] [
 				XML.NodeContent $ XML.ContentText $
 					s"世界"
 			],
 			XML.Element
-			(fromString "{jabber:component:accept}body") [] [
+			(s"{jabber:component:accept}body") [] [
 				XML.NodeContent $ XML.ContentText $
 					s"世界\n.\n"
 			]


@@ 208,7 354,9 @@ unit_messageToEmailWithDelay =
 	Just email
 	where
 	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
-	email = s"MIME-Version: 1.0\r\n\
+	timestamp = Time.formatTime Time.defaultTimeLocale "%s" date
+	email = s$"MIME-Version: 1.0\r\n\
+	\Message-ID: <" ++ timestamp ++ ".=00.=00@gateway.example.com>\r\n\
 	\To: t@example.com\r\n\
 	\From: \"f@example.com\" <f=40example=2Ecom@gateway.example.com>\r\n\
 	\Jabber-ID: f@example.com\r\n\


@@ 223,11 371,129 @@ unit_messageToEmailWithDelay =
 			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
 		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
 		XMPP.messagePayloads = [
-			XML.Element (fromString "{urn:xmpp:delay}delay") [(
+			XML.Element (s"{urn:xmpp:delay}delay") [(
 				s"{urn:xmpp:delay}stamp",
 				[XML.ContentText $ s"2009-02-22T00:10:00Z"]
 			)] [],
-			XML.Element (fromString "{jabber:component:accept}body")
+			XML.Element (s"{jabber:component:accept}body")
 			[] [XML.NodeContent $ XML.ContentText $ s"世界\n.\n"]
 		]
 	}
+
+unit_messageToEmailWithThread :: IO ()
+unit_messageToEmailWithThread =
+	fmap (MIME.renderMessage . snd) (
+		messageToEmail
+		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
+		date
+		message
+	)
+	@?=
+	Just email
+	where
+	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
+	timestamp = Time.formatTime Time.defaultTimeLocale "%s" date
+	email = s$"MIME-Version: 1.0\r\n\
+	\Message-ID: <" ++ timestamp ++ ".=00.athread@gateway.example.com>\r\n\
+	\To: t@example.com\r\n\
+	\From: \"f@example.com\" <f=40example=2Ecom@gateway.example.com>\r\n\
+	\Jabber-ID: f@example.com\r\n\
+	\Date: Mon, 01 Jan 1990 00:00:00 +0000\r\n\
+	\Content-Transfer-Encoding: base64\r\n\
+	\Content-Disposition: inline\r\n\
+	\Content-Type: text/plain; charset=utf-8\r\n\
+	\\r\n\
+	\5LiW55WMCi4K\r\n"
+	message = (XMPP.emptyMessage XMPP.MessageNormal) {
+		XMPP.messageTo =
+			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
+		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
+		XMPP.messagePayloads = [
+			XML.Element (s"{jabber:component:accept}body")
+			[] [XML.NodeContent $ XML.ContentText $ s"世界\n.\n"],
+			XML.Element (s"{jabber:component:accept}thread")
+			[] [XML.NodeContent $ XML.ContentText $ s"athread"]
+		]
+	}
+
+unit_messageToEmailWithCheoThread :: IO ()
+unit_messageToEmailWithCheoThread =
+	fmap (MIME.renderMessage . snd) (
+		messageToEmail
+		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
+		date
+		message
+	)
+	@?=
+	Just email
+	where
+	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
+	timestamp = Time.formatTime Time.defaultTimeLocale "%s" date
+	email = s$"MIME-Version: 1.0\r\n\
+	\Message-ID: <" ++ timestamp ++ ".=00.References=3A=20=3Cthing\
+		\=40foo=2Etld=3E@gateway.example.com>\r\n\
+	\References: <thing@foo.tld>\r\n\
+	\To: t@example.com\r\n\
+	\From: \"f@example.com\" <f=40example=2Ecom@gateway.example.com>\r\n\
+	\Jabber-ID: f@example.com\r\n\
+	\Date: Mon, 01 Jan 1990 00:00:00 +0000\r\n\
+	\Content-Transfer-Encoding: base64\r\n\
+	\Content-Disposition: inline\r\n\
+	\Content-Type: text/plain; charset=utf-8\r\n\
+	\\r\n\
+	\5LiW55WMCi4K\r\n"
+	message = (XMPP.emptyMessage XMPP.MessageNormal) {
+		XMPP.messageTo =
+			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
+		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
+		XMPP.messagePayloads = [
+			XML.Element (s"{jabber:component:accept}body")
+			[] [XML.NodeContent $ XML.ContentText $ s"世界\n.\n"],
+			XML.Element (s"{jabber:component:accept}thread") [] [
+				XML.NodeContent $ XML.ContentText $
+				s"References: <thing@foo.tld>"
+			]
+		]
+	}
+
+unit_messageToEmailWithDeepCheoThread :: IO ()
+unit_messageToEmailWithDeepCheoThread =
+	fmap (MIME.renderMessage . snd) (
+		messageToEmail
+		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
+		date
+		message
+	)
+	@?=
+	Just email
+	where
+	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
+	timestamp = Time.formatTime Time.defaultTimeLocale "%s" date
+	email = s$"MIME-Version: 1.0\r\n\
+	\Message-ID: <" ++ timestamp ++ ".=00.References=3A=20=3C1=40t=2Et=3E=\
+		\20=3C2=40t=2Et=3E=20=3C3=40t=2Et=3E=20=3C4=40t=2Et=3E=20=3C5=\
+		\40t=2Et=3E=20=3C6=40t=2Et=3E@gateway.example.com>\r\n\
+	\References: <1@t.t> <3@t.t> <4@t.t> <5@t.t> <6@t.t>\r\n\
+	\To: t@example.com\r\n\
+	\From: \"f@example.com\" <f=40example=2Ecom@gateway.example.com>\r\n\
+	\Jabber-ID: f@example.com\r\n\
+	\Date: Mon, 01 Jan 1990 00:00:00 +0000\r\n\
+	\Content-Transfer-Encoding: base64\r\n\
+	\Content-Disposition: inline\r\n\
+	\Content-Type: text/plain; charset=utf-8\r\n\
+	\\r\n\
+	\5LiW55WMCi4K\r\n"
+	message = (XMPP.emptyMessage XMPP.MessageNormal) {
+		XMPP.messageTo =
+			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
+		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
+		XMPP.messagePayloads = [
+			XML.Element (s"{jabber:component:accept}body")
+			[] [XML.NodeContent $ XML.ContentText $ s"世界\n.\n"],
+			XML.Element (s"{jabber:component:accept}thread") [] [
+				XML.NodeContent $ XML.ContentText $
+				s"References: <1@t.t> <2@t.t> <3@t.t> <4@t.t>\
+				\ <5@t.t> <6@t.t>"
+			]
+		]
+	}