~singpolyma/cheogram-smtp

3f0a9da4642fea8a970d4698eabc148fe0f6caf2 — Stephen Paul Weber 2 years ago ccfeda0
Add default subject and Chat-Version header
2 files changed, 20 insertions(+), 4 deletions(-)

M Email.hs
M test/EmailTest.hs
M Email.hs => Email.hs +15 -1
@@ 7,6 7,7 @@ import Control.Error                             (headZ)
import Data.Time.Clock                           (UTCTime)
import Control.Lens 
	(Const, Leftmost, filtered, firstOf, view, _Right, set, at)
import qualified Data.Text                       as T
import qualified Data.Attoparsec.ByteString.Lazy as Atto
import qualified Data.ByteString                 as ByteString
import qualified Data.ByteString.Builder         as Builder


@@ 97,6 98,17 @@ emailToStanza toJid email =
		firstOf (MIME.headers . MIME.header (s"subject")) email
	Just from = toJid =<< headZ =<< firstOf MIME.headerFrom email


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

typeHeaders :: XMPP.Message -> MIME.MIMEMessage -> MIME.MIMEMessage
typeHeaders XMPP.Message { XMPP.messageType = XMPP.MessageChat } =
	set (MIME.headers . at (s"Chat-Version")) (Just $ s"1.0")
typeHeaders _ = id

messageToEmail ::
	   MIME.Domain
	-> UTCTime


@@ 108,6 120,7 @@ messageToEmail fromDomain now message@XMPP.Message {
	} | Just bodyTxt <- getBody message,
	    Right toAddress <- MIME.parse MIME.address unescapedToNode =
		Just (fromMailbox,
			typeHeaders message $
			set MIME.headerTo [toAddress] $
			set MIME.headerFrom [fromMailbox] $
			set (MIME.headers . at (s"Subject")) subjectHeader $


@@ 118,7 131,8 @@ messageToEmail fromDomain now message@XMPP.Message {
	dateHeader = fromMaybe now $ parseXMPPTime =<<
		XML.attributeText (s"{urn:xmpp:delay}stamp") =<<
		child (s"{urn:xmpp:delay}delay") message
	subjectHeader = MIME.encodeEncodedWords <$> getSubject message
	subjectHeader = MIME.encodeEncodedWords <$>
		(getSubject message <|> defaultSubject message)
	fromMailbox = jidToMailbox from fromDomain
	unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode
messageToEmail _ _ _ = Nothing

M test/EmailTest.hs => test/EmailTest.hs +5 -3
@@ 90,8 90,8 @@ unit_emailToStanzUTF8Subject =
	\\n\
	\Hello\n"

unit_messageToEmail :: IO ()
unit_messageToEmail =
unit_messageToEmailChat :: IO ()
unit_messageToEmailChat =
	fmap (MIME.renderMessage . snd) (
		messageToEmail
		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")


@@ 103,15 103,17 @@ unit_messageToEmail =
	where
	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
	email = s"MIME-Version: 1.0\r\n\
	\Chat-Version: 1.0\r\n\
	\To: t@example.com\r\n\
	\From: f%40example%2Ecom@gateway.example.com\r\n\
	\Subject: =?utf-8?B?Q2hhdDog5LiW55WMCi4K?=\r\n\
	\date: Mon, 01 Jan 1990 00:00:00 +0000\r\n\
	\Content-Transfer-Encoding: base64\r\n\
	\Content-Disposition: inline\r\n\
	\Content-Type: text/plain; charset=utf-8\r\n\
	\\r\n\
	\5LiW55WMCi4K\r\n"
	message = (XMPP.emptyMessage XMPP.MessageNormal) {
	message = (XMPP.emptyMessage XMPP.MessageChat) {
		XMPP.messageTo =
			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",