From eccfa5dc7d8ae7ec8e7208787d905b764c1ffdf6 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Tue, 18 Oct 2022 16:01:09 -0500 Subject: [PATCH] Add to and cc headers as XEP-0033 --- Email.hs | 40 +++++++++++++++++++++- test/EmailTest.hs | 86 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 125 insertions(+), 1 deletion(-) diff --git a/Email.hs b/Email.hs index 8bd896b..5bfd77a 100644 --- a/Email.hs +++ b/Email.hs @@ -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 } = diff --git a/test/EmailTest.hs b/test/EmailTest.hs index c7c43cf..3c09b4e 100644 --- a/test/EmailTest.hs +++ b/test/EmailTest.hs @@ -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 \n\ + \Cc: g, cc@example.com\n\ \Subject: subject\n\ \Message-ID: \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" ], -- 2.38.5