~singpolyma/cheogram-smtp

d0ad51c2725152293a20273fba499b50e9efdffc — Stephen Paul Weber 2 years ago 43c43ef
Strip off "[Re: ]Chat: " subject lines from deltachat-style messengers
3 files changed, 93 insertions(+), 27 deletions(-)

M Email.hs
M Util.hs
M test/EmailTest.hs
M Email.hs => Email.hs +21 -6
@@ 153,29 153,44 @@ emailToThread domain email = thread <&> \threadID ->
	msgid = firstOf (MIME.headers . MIME.header (s"message-id")) email
	refs = firstOf (MIME.headers . MIME.header (s"references")) email

emailSubject :: MIME.MIMEMessage -> Maybe Text
emailSubject email = MIME.decodeEncodedWords MIME.defaultCharsets <$>
		firstOf (MIME.headers . MIME.header (s"subject")) email

chatEmailSubject :: MIME.MIMEMessage -> Maybe Text
chatEmailSubject =
	mfilter (not . (s"Re: Chat: " `T.isPrefixOf`)) .
	mfilter (not . (s"Chat: " `T.isPrefixOf`)) .
	emailSubject

emailToSubject :: XMPP.MessageType -> MIME.MIMEMessage -> Maybe XML.Element
emailToSubject = fmap (mkElement (s"{jabber:component:accept}subject")) .: go
	where
	go XMPP.MessageChat = chatEmailSubject
	go _ = emailSubject

emailToStanza ::
	   Text
	-> MIME.MIMEMessage
	-> XMPP.Message
emailToStanza domain email =
	(XMPP.emptyMessage $ emailToMessageType email) {
	(XMPP.emptyMessage typ) {
		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 ++ maybeToList (emailToThread domain email)
		] ++ subject ++ nick ++ mid ++
		maybeToList (emailToThread domain email)
	}
	where
	typ = emailToMessageType email
	subject = maybeToList $ emailToSubject typ email
	mid = maybeToList $ emailToOriginID email
	nick = maybeToList $ fmap (\n ->
			XML.Element (s"{http://jabber.org/protocol/nick}nick")
				[] [XML.NodeContent $ XML.ContentText n]
		) fn
	Just textBody = firstOf plainTextBody email
	Just subject = MIME.decodeEncodedWords MIME.defaultCharsets <$>
		firstOf (MIME.headers . MIME.header (s"subject")) email
	Just fromMailbox@(MIME.Mailbox fn _) =
		headZ =<< firstOf (MIME.headerFrom MIME.defaultCharsets) email


M Util.hs => Util.hs +7 -0
@@ 152,3 152,10 @@ bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain
parseXMPPTime :: Text -> Maybe UTCTime
parseXMPPTime =
	parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" . textToString

mkElement :: XML.Name -> Text -> XML.Element
mkElement name content = XML.Element name []
	[XML.NodeContent $ XML.ContentText content]

(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = (.) . (.)

M test/EmailTest.hs => test/EmailTest.hs +65 -21
@@ 46,12 46,12 @@ unit_emailToStanzaSimple =
		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"{jabber:component:accept}subject") [] [
				XML.NodeContent $ XML.ContentText $ s"subject"
			],
			XML.Element (s"{http://jabber.org/protocol/nick}nick")
			[] [
				XML.NodeContent $ XML.ContentText $ s"Human"


@@ 83,9 83,31 @@ unit_emailToStanzaChat =
		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"
			],
			]
		]
	}
	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\
	\Chat-Version: 1.0\n\
	\\n\
	\Hello\n"

unit_emailToStanzaChatFakeSubject :: IO ()
unit_emailToStanzaChatFakeSubject =
	show (emailToStanza (s"gateway.example.com") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageChat) {
		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"
			]


@@ 95,7 117,29 @@ unit_emailToStanzaChat =
	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\
	\Subject: Chat: Hello\n\
	\Chat-Version: 1.0\n\
	\\n\
	\Hello\n"

unit_emailToStanzaChatReFakeSubject :: IO ()
unit_emailToStanzaChatReFakeSubject =
	show (emailToStanza (s"gateway.example.com") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageChat) {
		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"
			]
		]
	}
	where
	Right message = MIME.parse (MIME.message MIME.mime) email
	email = encodeUtf8 $ s"To: to@example.com\n\
	\From: f@example.com\n\
	\Subject: Re: Chat: Hello\n\
	\Chat-Version: 1.0\n\
	\\n\
	\Hello\n"


@@ 108,10 152,10 @@ unit_emailToStanzUTF8Subject =
		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"世界"],
			XML.Element (s"{jabber:component:accept}body") []
				[XML.NodeContent $ XML.ContentText $ s"Hello\n"]
				[XML.NodeContent $ XML.ContentText $s"Hello\n"],
			XML.Element (s"{jabber:component:accept}subject") []
				[XML.NodeContent $ XML.ContentText $ s"世界"]
		]
	}
	where


@@ 130,12 174,12 @@ unit_emailToStanzaReply =
		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"{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"]


@@ 169,12 213,12 @@ unit_emailToStanzaReplyNulThread =
		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"{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"]


@@ 205,12 249,12 @@ unit_emailToStanzaDeepReply =
		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"{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"]


@@ 330,14 374,14 @@ unit_messageToEmailWithSubject =
		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
		XMPP.messagePayloads = [
			XML.Element
			(s"{jabber:component:accept}subject") [] [
			(s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $
					s"世界"
					s"世界\n.\n"
			],
			XML.Element
			(s"{jabber:component:accept}body") [] [
			(s"{jabber:component:accept}subject") [] [
				XML.NodeContent $ XML.ContentText $
					s"世界\n.\n"
					s"世界"
			]
		]
	}