~singpolyma/cheogram-smtp

3531a4e8739e9ee195a962ee89229423ea8ae227 — Stephen Paul Weber 2 years ago 7b63cfa
Incoming deltachat message is of type=chat
2 files changed, 42 insertions(+), 7 deletions(-)

M Email.hs
M test/EmailTest.hs
M Email.hs => Email.hs +17 -7
@@ 83,12 83,27 @@ jidToMailbox :: XMPP.JID -> MIME.Domain -> MIME.Mailbox
jidToMailbox jid domain = MIME.Mailbox (Just $ bareTxt jid) $
	MIME.AddrSpec (jidToLocalpart jid) domain

emailToMessageType :: MIME.MIMEMessage -> XMPP.MessageType
emailToMessageType email
	| Just _ <- chatVersion email =
		XMPP.MessageChat
	| otherwise = XMPP.MessageNormal
	where
	chatVersion = firstOf (MIME.headers . MIME.header (s"Chat-Version"))

emailToOriginID :: MIME.MIMEMessage -> Maybe XML.Element
emailToOriginID email = fmap originID $ hush . MIME.parse messageID =<<
	firstOf (MIME.headers . MIME.header (s"message-id")) email
	where
	originID msgid = XML.Element (s"{urn:xmpp:sid:0}origin-id")
		[(s"{urn:xmpp:sid:0}id", [XML.ContentText msgid])] []

emailToStanza ::
	   (MIME.Mailbox -> Maybe XMPP.JID)
	-> MIME.MIMEMessage
	-> XMPP.Message
emailToStanza toJid email =
	(XMPP.emptyMessage XMPP.MessageNormal) {
	(XMPP.emptyMessage $ emailToMessageType email) {
		XMPP.messageFrom = toJid fromMailbox,
		XMPP.messagePayloads = [
			XML.Element (s"{jabber:component:accept}subject") []


@@ 98,11 113,7 @@ emailToStanza toJid email =
		] ++ nick ++ mid
	}
	where
	mid = maybeToList $ fmap (\msgid ->
			XML.Element (s"{urn:xmpp:sid:0}origin-id")
			[(s"{urn:xmpp:sid:0}id", [XML.ContentText msgid])] []
		) $ hush . MIME.parse messageID =<<
		firstOf (MIME.headers . MIME.header (s"message-id")) email
	mid = maybeToList $ emailToOriginID email
	nick = maybeToList $ fmap (\n ->
			XML.Element (s"{http://jabber.org/protocol/nick}nick")
				[] [XML.NodeContent $ XML.ContentText n]


@@ 113,7 124,6 @@ emailToStanza toJid email =
	Just fromMailbox@(MIME.Mailbox fn _) =
		headZ =<< firstOf (MIME.headerFrom MIME.defaultCharsets) email


defaultSubject :: XMPP.Message -> Maybe Text
defaultSubject message@XMPP.Message { XMPP.messageType = XMPP.MessageChat } =
	(s"Chat: " ++) . T.take 80 <$> getBody message

M test/EmailTest.hs => test/EmailTest.hs +25 -0
@@ 70,6 70,31 @@ unit_emailToStanzaSimple =
	\\n\
	\Hello\n"

unit_emailToStanzaChat :: IO ()
unit_emailToStanzaChat =
	show (emailToStanza (mailboxToJID $ 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}subject") [] [
				XML.NodeContent $ XML.ContentText $ s"subject"
			],
			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: subject\n\
	\Chat-Version: 1.0\n\
	\\n\
	\Hello\n"

unit_emailToStanzUTF8Subject :: IO ()
unit_emailToStanzUTF8Subject =
	show (emailToStanza (mailboxToJID $ s"gateway.example.com") message)