~singpolyma/cheogram-smtp: 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"
 			],