2 files changed, 168 insertions(+), 13 deletions(-)

M Email.hs
M test/EmailTest.hs

@@ 448,17 448,26 @@ 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">")) $
+
+mkMessageID' :: MIME.Domain -> UTCTime -> String -> String -> ByteString
+mkMessageID' domain now sid thread = ((s"<" ++) . (++ s">")) $
 	MIME.renderAddressSpec $ MIME.AddrSpec
 	(fromString $ time ++ "." ++ sid ++ "." ++ thread) domain
 	where
-	sid = maybe "=00" equalsEncode $ XMPP.stanzaID message
-	thread =
-		maybe "=00" (equalsEncode . mconcat . XML.elementText) $
-		child (s"{jabber:component:accept}thread") message
 	time = formatTime defaultTimeLocale "%s" now
 
+mkMessageID :: MIME.Domain -> UTCTime -> XMPP.Message -> ByteString
+mkMessageID domain now message =
+	mkMessageID' domain now sid thread
+	where
+	sid = maybe "=00" equalsEncode $ XMPP.stanzaID message
+	thread = fromMaybe "=00" $ mkThread message
+
+mkThread :: XMPP.Message -> Maybe String
+mkThread message =
+	equalsEncode . mconcat . XML.elementText <$>
+	child (s"{jabber:component:accept}thread") message
+
 mkReferences :: XMPP.Message -> Maybe ByteString
 mkReferences =
 	fmap (limitReferencesLength . encodeUtf8) .


@@ 620,15 629,20 @@ messageToEmailIO domain message = do
 	attachments <- messageToAttachments message
 	now <- fromIO_ getCurrentTime
 	let mime = messageToMIME boundaries attachments message
-	return $ messageToEmail domain now message =<< mime
+	let xdc = any (matchWebXDC . mimeType) attachments
+	return $ messageToEmail domain now xdc message =<< mime
+
+matchWebXDC :: MIME.ContentType -> Bool
+matchWebXDC = MIME.matchContentType (s"application") (Just $ s"webxdc+zip")
 
 messageToEmail ::
 	   MIME.Domain
 	-> UTCTime
+	-> Bool
 	-> XMPP.Message
 	-> MIME.MIMEMessage
 	-> Either XMPP.Message EmailWithEnvelope
-messageToEmail fromDomain now message@XMPP.Message {
+messageToEmail fromDomain now threadHead message@XMPP.Message {
 		XMPP.messageFrom = Just from,
 		XMPP.messageTo = Just (XMPP.JID (Just toNode) _ _)
 	} mime | Right toMailbox@(MIME.Mailbox _ toAddrSpec) <- parsedToNode =


@@ 655,9 669,17 @@ messageToEmail fromDomain now message@XMPP.Message {
 		)
 		message
 	where
-	mid = mkMessageID fromDomain now message
+	mid
+		| threadHead = mkMessageID fromDomain epoch
+			(message { XMPP.messageID = Nothing })
+		| otherwise = mkMessageID fromDomain now message
 	inreplyto = (lastZ . C8.words) =<< refs
-	refs = mkReferences message
+	refs = mkReferences message <|>
+		mfilter (const $ not threadHead) (fmap
+				(mkMessageID' fromDomain epoch "=00")
+				(mkThread message)
+			)
+	Just epoch = parseXMPPTime (s"1970-01-01T00:00:00Z")
 	jidHeader = Just $ MIME.encodeEncodedWords (bareTxt from)
 	dateHeader = utcToZonedTime utc $ fromMaybe now $ parseXMPPTime =<<
 		XML.attributeText (s"stamp") =<<


@@ 670,7 692,7 @@ messageToEmail fromDomain now message@XMPP.Message {
 	parsedToNode =
 		MIME.parse (MIME.mailbox MIME.defaultCharsets) unescapedToNode
 	unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode
-messageToEmail _ _ message _ = Left $
+messageToEmail _ _ _ message _ = Left $
 	messageError
 	(errorPayload "modify" "bad-request" (s"Could not process message") [])
 	message

@@ 69,8 69,10 @@ messageToEmailTest ::
 	-> XMPP.Message
 	-> Either XMPP.Message EmailWithEnvelope
 messageToEmailTest d now as m =
-	messageToEmail d now m =<<
+	messageToEmail d now xdc m =<<
 	messageToMIME (boundary1, boundary2) as m
+	where
+	xdc = any (matchWebXDC . mimeType) as
 
 unit_emailToStanzaSimple :: IO ()
 unit_emailToStanzaSimple =


@@ 832,6 834,8 @@ unit_messageToEmailWithThread =
 	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\
+	\References: <0.=00.athread@gateway.example.com>\r\n\
+	\In-Reply-To: <0.=00.athread@gateway.example.com>\r\n\
 	\To: t@example.com\r\n\
 	\From: f <f=40example=2Ecom@gateway.example.com>\r\n\
 	\Jabber-ID: f@example.com\r\n\


@@ 1013,6 1017,135 @@ unit_messageToEmailWebXDCUpdate =
 		]
 	}
 
+unit_messageToEmailWebXDCUpdateXMPPThread :: IO ()
+unit_messageToEmailWebXDCUpdateXMPPThread =
+	hush (fmap (MIME.renderMessage . emailMessage) (
+		messageToEmailTest
+		(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.xt@gateway.example.com>\r\n\
+	\References: <0.=00.xt@gateway.example.com>\r\n\
+	\In-Reply-To: <0.=00.xt@gateway.example.com>\r\n\
+	\To: t@example.com\r\n\
+	\From: f <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-Type: multipart/mixed; boundary=b1\r\n\r\n\
+	\--b1\r\n\
+	\MIME-Version: 1.0\r\n\
+	\Content-Type: multipart/report; \
+		\report-type=status-update; boundary=b2\r\n\r\n\
+	\--b2\r\n\
+	\MIME-Version: 1.0\r\n\
+	\Content-Transfer-Encoding: 7bit\r\n\
+	\Content-Disposition: inline\r\n\
+	\Content-Type: text/plain; charset=us-ascii\r\n\r\n\
+	\WebXDC update\r\n\
+	\--b2\r\n\
+	\MIME-Version: 1.0\r\n\
+	\Content-Transfer-Encoding: 7bit\r\n\
+	\Content-Disposition: attachment; filename=status-update.json\r\n\
+	\Content-Type: application/json\r\n\r\n\
+	\{\"updates\":[{\"document\":\"some document\",\"payload\":{}\
+	\,\"summary\":\"some summary\",\"info\":\"some info\"}]}\r\n\
+	\--b2--\r\n\r\n\
+	\--b1--\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"some info"],
+			XML.Element (s"{urn:xmpp:webxdc:0}x") [] [
+				XML.NodeElement $ XML.Element
+				(s"{urn:xmpp:webxdc:0}document") [] [
+					XML.NodeContent $ XML.ContentText $
+					s"some document"
+				],
+				XML.NodeElement $
+				XML.Element (s"{urn:xmpp:webxdc:0}summary") [] [
+					XML.NodeContent $ XML.ContentText $
+					s"some summary"
+				],
+				XML.NodeElement $
+				XML.Element (s"{urn:xmpp:json:0}json") [] [
+					XML.NodeContent $ XML.ContentText $
+					s"{}"
+				]
+			],
+			XML.Element (s"{jabber:component:accept}thread") [] [
+				XML.NodeContent $ XML.ContentText $
+				s"xt"
+			]
+		]
+	}
+
+unit_messageToEmailWebXDC :: IO ()
+unit_messageToEmailWebXDC =
+	hush (fmap (MIME.renderMessage . emailMessage) (
+		messageToEmailTest
+		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
+		date
+		attachments
+		message
+	))
+	@?=
+	Just email
+	where
+	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
+	email = s"MIME-Version: 1.0\r\n\
+	\Message-ID: <0.=00.xmppthread@gateway.example.com>\r\n\
+	\To: t@example.com\r\n\
+	\From: f <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-Type: multipart/mixed; boundary=b1\r\n\r\n\
+	\--b1\r\n\
+	\MIME-Version: 1.0\r\n\
+	\Content-Transfer-Encoding: 7bit\r\n\
+	\Content-Disposition: inline\r\n\
+	\Content-Type: text/plain; charset=us-ascii\r\n\r\n\
+	\the body\r\n\
+	\--b1\r\n\
+	\MIME-Version: 1.0\r\n\
+	\Content-Transfer-Encoding: 7bit\r\n\
+	\Content-Disposition: attachment; filename=widget.xdc\r\n\
+	\Content-Type: application/webxdc+zip\r\n\r\n\
+	\data\r\n\
+	\--b1--\r\n"
+	attachments = [
+			Attachment
+			(MIME.ContentType
+				(s"application") (s"webxdc+zip") mempty)
+			(s"widget.xdc")
+			(s"data")
+		]
+	message = (XMPP.emptyMessage XMPP.MessageNormal) {
+		XMPP.messageID = Just $ s"sid",
+		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 $ s"the body"
+			],
+			XML.Element (s"{jabber:component:accept}thread") [] [
+				XML.NodeContent $ XML.ContentText $
+				s"xmppthread"
+			]
+		]
+	}
+
 unit_messageToEmailAttachment :: IO ()
 unit_messageToEmailAttachment =
 	hush (fmap (MIME.renderMessage . emailMessage) (


@@ 1051,7 1184,7 @@ unit_messageToEmailAttachment =
 			Attachment
 			MIME.contentTypeApplicationOctetStream
 			(s"afile.bin")
-                        (s"data")
+			(s"data")
 		]
 	message = (XMPP.emptyMessage XMPP.MessageNormal) {
 		XMPP.messageTo =