~singpolyma/cheogram-smtp

eccfa5dc7d8ae7ec8e7208787d905b764c1ffdf6 β€” Stephen Paul Weber 7 months ago dd13c27
Add to and cc headers as XEP-0033
2 files changed, 125 insertions(+), 1 deletions(-)

M Email.hs
M test/EmailTest.hs
M Email.hs => Email.hs +39 -1
@@ 24,6 24,7 @@ import qualified Data.Attoparsec.ByteString.Lazy as Atto
import qualified Data.MIME                       as MIME
import qualified Data.MIME.Charset               as MIME
import qualified Data.MIME.EncodedWord           as MIME
import qualified Data.RFC5322.Internal           as MIME -- TODO
import qualified Data.XML.Types                  as XML
import qualified Network.Protocol.XMPP           as XMPP
import qualified Network.URI                     as URI


@@ 73,6 74,16 @@ messageID =
messageOptionalMboxFrom :: Atto.Parser MIME.MIMEMessage
messageOptionalMboxFrom = Atto.option () mboxFrom *> MIME.message MIME.mime

data AddressLax = Address MIME.Address | AddressLax Text

addressLax :: MIME.CharsetLookup -> Atto.Parser AddressLax
addressLax charsets =
	(Address <$> MIME.address charsets) <|>
	(AddressLax . decodeUtf8 <$> MIME.localPart)

addressLaxList :: MIME.CharsetLookup -> Atto.Parser [AddressLax]
addressLaxList charsets = addressLax charsets `Atto.sepBy` Atto.satisfy (==0x2C)

isTextPlain :: MIME.WireEntity -> Bool
isTextPlain = MIME.matchContentType (s"text") (Just $ s"plain") .
	view MIME.contentType


@@ 228,6 239,22 @@ emailToSubject = fmap (mkElement (s"{jabber:component:accept}subject")) .: go
bytesToCid :: ByteString -> CID.CID
bytesToCid = CID.newCidV1 CID.Raw . Hash.hashWith Hash.SHA512

addressJids :: Text -> AddressLax -> [XMPP.JID]
addressJids domain (Address (MIME.Single mailbox)) =
	justZ $ mailboxToJID domain mailbox
addressJids domain (Address (MIME.Group _ mailboxes)) =
	justZ . mailboxToJID domain =<< mailboxes
addressJids domain (AddressLax addr) =
	justZ $ XMPP.parseJID $ escapeJid addr ++ s"@" ++ domain

addressEl :: String -> XMPP.JID -> XML.Element
addressEl typ jid =
	XML.Element (s"{http://jabber.org/protocol/address}address") [
		(s"type", [fromString typ]),
		(s"delivered", [s"true"]),
		(s"jid", [XML.ContentText $ XMPP.formatJID jid])
	] []

emailToStanza ::
	   Text
	-> Text


@@ 238,7 265,8 @@ emailToStanza domain attachmentUrl email = (
			XMPP.messageFrom = mailboxToJID domain fromMailbox,
			XMPP.messagePayloads = [
				XML.Element (s"{jabber:component:accept}body")
				[] [XML.NodeContent $ XML.ContentText textBody]
				[] [XML.NodeContent $ XML.ContentText textBody],
				addresses
			] ++ subject ++ nick ++ mid ++ attachmentsOOB ++
			maybeToList (emailToThread domain email)
		},


@@ 272,6 300,16 @@ emailToStanza domain attachmentUrl email = (
	Just textBody = firstOf plainTextBody email
	Just fromMailbox@(MIME.Mailbox fn _) =
		headZ =<< firstOf (MIME.headerFrom MIME.defaultCharsets) email
	addresses = XML.Element
		(s"{http://jabber.org/protocol/address}addresses") [] $
		map (XML.NodeElement . addressEl "to") to ++
		map (XML.NodeElement . addressEl "cc") cc
	to = addressJids domain =<< join . justZ . hush .
		MIME.parse (addressLaxList MIME.defaultCharsets) =<<
		toListOf (MIME.headers . MIME.header (s"to")) email
	cc = addressJids domain =<< join . justZ . hush .
		MIME.parse (addressLaxList MIME.defaultCharsets) =<<
		toListOf (MIME.headers . MIME.header (s"cc")) email

defaultSubject :: XMPP.Message -> Maybe Text
defaultSubject message@XMPP.Message { XMPP.messageType = XMPP.MessageChat } =

M test/EmailTest.hs => test/EmailTest.hs +86 -0
@@ 15,6 15,18 @@ import Util
import Email
import TestInstances ()

addressesElName :: XML.Name
addressesElName = s"{http://jabber.org/protocol/address}addresses"

addressElName :: XML.Name
addressElName = s"{http://jabber.org/protocol/address}address"

toJid :: XML.Content
toJid = s"to\\40example.com@gateway.example.com"

ccJid :: XML.Content
ccJid = s"cc\\40example.com@gateway.example.com"

mailboxFromLocal :: Text -> MIME.Mailbox
mailboxFromLocal local = MIME.Mailbox Nothing $
	MIME.AddrSpec (encodeUtf8 local) (MIME.DomainLiteral mempty)


@@ 51,6 63,23 @@ unit_emailToStanzaSimple =
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element addressesElName [] [
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"to"]),
					(s"delivered", [s"true"]),
					(s"jid", [toJid])
				] [],
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"cc"]),
					(s"delivered", [s"true"]),
					(s"jid", [s"g@gateway.example.com"])
				] [],
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"cc"]),
					(s"delivered", [s"true"]),
					(s"jid", [ccJid])
				] []
			],
			XML.Element (s"{jabber:component:accept}subject") [] [
				XML.NodeContent $ XML.ContentText $ s"subject"
			],


@@ 72,6 101,7 @@ unit_emailToStanzaSimple =
	Right message = MIME.parse (MIME.message MIME.mime) email
	email = encodeUtf8 $ s"To: to@example.com\n\
	\From: Human <f@example.com>\n\
	\Cc: g, cc@example.com\n\
	\Subject: subject\n\
	\Message-ID: <boop-id@ids.example.com>\n\
	\\n\


@@ 88,6 118,13 @@ unit_emailToStanzaChat =
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element addressesElName [] [
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"to"]),
					(s"delivered", [s"true"]),
					(s"jid", [toJid])
				] []
			],
			XML.Element (s"{jabber:component:accept}subject") [] [
				XML.NodeContent $ XML.ContentText $ s"subject"
			]


@@ 112,6 149,13 @@ unit_emailToStanzaChatFakeSubject =
		XMPP.messagePayloads = [
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element addressesElName [] [
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"to"]),
					(s"delivered", [s"true"]),
					(s"jid", [toJid])
				] []
			]
		]
	}


@@ 134,6 178,13 @@ unit_emailToStanzaChatReFakeSubject =
		XMPP.messagePayloads = [
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element addressesElName [] [
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"to"]),
					(s"delivered", [s"true"]),
					(s"jid", [toJid])
				] []
			]
		]
	}


@@ 156,6 207,13 @@ unit_emailToStanzUTF8Subject =
		XMPP.messagePayloads = [
			XML.Element (s"{jabber:component:accept}body") []
				[XML.NodeContent $ XML.ContentText $s"Hello\n"],
			XML.Element addressesElName [] [
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"to"]),
					(s"delivered", [s"true"]),
					(s"jid", [toJid])
				] []
			],
			XML.Element (s"{jabber:component:accept}subject") []
				[XML.NodeContent $ XML.ContentText $ s"δΈ–η•Œ"]
		]


@@ 179,6 237,13 @@ unit_emailToStanzaReply =
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element addressesElName [] [
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"to"]),
					(s"delivered", [s"true"]),
					(s"jid", [toJid])
				] []
			],
			XML.Element (s"{jabber:component:accept}subject") [] [
				XML.NodeContent $ XML.ContentText $ s"subject"
			],


@@ 218,6 283,13 @@ unit_emailToStanzaReplyNulThread =
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element addressesElName [] [
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"to"]),
					(s"delivered", [s"true"]),
					(s"jid", [toJid])
				] []
			],
			XML.Element (s"{jabber:component:accept}subject") [] [
				XML.NodeContent $ XML.ContentText $ s"subject"
			],


@@ 254,6 326,13 @@ unit_emailToStanzaDeepReply =
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element addressesElName [] [
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"to"]),
					(s"delivered", [s"true"]),
					(s"jid", [toJid])
				] []
			],
			XML.Element (s"{jabber:component:accept}subject") [] [
				XML.NodeContent $ XML.ContentText $ s"subject"
			],


@@ 314,6 393,13 @@ unit_emailToStanzaDeepInReplyTo =
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element addressesElName [] [
				XML.NodeElement $ XML.Element addressElName [
					(s"type", [s"to"]),
					(s"delivered", [s"true"]),
					(s"jid", [toJid])
				] []
			],
			XML.Element (s"{jabber:component:accept}subject") [] [
				XML.NodeContent $ XML.ContentText $ s"subject"
			],