~singpolyma/cheogram-smtp

11588b85e8f1251d778e379adf74702adb49aced — Stephen Paul Weber 2 years ago fdd71cf
Send along message id as stanza origin-id (XEP-0359)
2 files changed, 23 insertions(+), 4 deletions(-)

M Email.hs
M test/EmailTest.hs
M Email.hs => Email.hs +15 -2
@@ 3,7 3,7 @@ module Email where
import BasicPrelude
import Prelude ()
import Data.Char                                 (isAscii, isAlphaNum)
import Control.Error                             (headZ)
import Control.Error                             (headZ, hush)
import Data.Time.Clock                           (UTCTime)
import Control.Lens 
	(Const, Leftmost, filtered, firstOf, view, _Right, set, at)


@@ 29,6 29,14 @@ mboxFrom =
	MIME.crlf *>
	pure ()

messageID :: Atto.Parser Text
messageID =
	Atto.skipWhile (Atto.inClass " \t\n\r") *>
	Atto.satisfy (==0x3C) *>
	(decodeUtf8 <$> Atto.takeTill (==0x3E)) <* -- @ also required by rfc5332
	Atto.satisfy (==0x3E) <*
	Atto.skipWhile (Atto.inClass " \t\n\r")

messageOptionalMboxFrom :: Atto.Parser MIME.MIMEMessage
messageOptionalMboxFrom = Atto.option () mboxFrom *> MIME.message MIME.mime



@@ 92,9 100,14 @@ emailToStanza toJid email =
				[XML.NodeContent $ XML.ContentText subject],
			XML.Element (s"{jabber:component:accept}body") []
				[XML.NodeContent $ XML.ContentText textBody]
		] ++ nick
		] ++ 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
	nick = maybeToList $ fmap (\n ->
			XML.Element (s"{http://jabber.org/protocol/nick}nick")
				[] [XML.NodeContent $ XML.ContentText n]

M test/EmailTest.hs => test/EmailTest.hs +8 -2
@@ 51,9 51,14 @@ unit_emailToStanzaSimple =
			XML.Element (s"{jabber:component:accept}body") [] [
				XML.NodeContent $ XML.ContentText $ s"Hello\n"
			],
			XML.Element (s"{http://jabber.org/protocol/nick}nick") [] [
			XML.Element (s"{http://jabber.org/protocol/nick}nick")
			[] [
				XML.NodeContent $ XML.ContentText $ s"Human"
			]
			],
			XML.Element (s"{urn:xmpp:sid:0}origin-id") [(
				s"{urn:xmpp:sid:0}id",
				[XML.ContentText $ s"boop-id@ids.example.com"]
			)] []
		]
	}
	where


@@ 61,6 66,7 @@ unit_emailToStanzaSimple =
	email = encodeUtf8 $ s"To: to@example.com\n\
	\From: Human <f@example.com>\n\
	\Subject: subject\n\
	\Message-ID: <boop-id@ids.example.com>\n\
	\\n\
	\Hello\n"