~singpolyma/cheogram-smtp

b82266370b72329fc594dcb50307305259ad5be0 — Stephen Paul Weber 2 years ago d0ad51c
Return XMPP error when message cannot be sent as email

Special case to give nicer error when it's because the JID does not map
to a valid email address. Or else generic error.

This commit also (ugh, also) changes our sendmail call to set recipients
on command line instead of taking them from the headers, which doesn't
change anythnig now really but means we can safely set other headers
later.
4 files changed, 57 insertions(+), 26 deletions(-)

M Email.hs
M Util.hs
M gateway.hs
M test/EmailTest.hs
M Email.hs => Email.hs +35 -7
@@ 18,6 18,7 @@ import qualified Data.MIME.EncodedWord           as MIME
import qualified Data.XML.Types                  as XML
import qualified Network.Protocol.XMPP           as XMPP
import qualified Network.URI                     as URI
import qualified Network.Mail.Mime               as Mail

import Util



@@ 223,27 224,51 @@ mkReferences =
	fmap (mconcat . XML.elementText) .
	child (s"{jabber:component:accept}thread")

data EmailWithEnvelope = EmailWithEnvelope {
	emailMessage :: MIME.MIMEMessage,
	emailEnvelopeFrom :: MIME.AddrSpec,
	emailEnvelopeTo :: MIME.AddrSpec
}

sendEmail :: (MonadIO m) => EmailWithEnvelope -> m ()
sendEmail (EmailWithEnvelope mail from to) =
	liftIO $ Mail.sendmailCustom "/usr/sbin/sendmail" [
		"-i",
		"-f", textToString $ decodeUtf8 $ MIME.renderAddressSpec from,
		"--", textToString $ decodeUtf8 $ MIME.renderAddressSpec to
	] (MIME.renderMessage mail)

messageToEmail ::
	   MIME.Domain
	-> UTCTime
	-> XMPP.Message
	-> Maybe (MIME.Mailbox, MIME.MIMEMessage)
	-> Either XMPP.Message EmailWithEnvelope
messageToEmail fromDomain now message@XMPP.Message {
		XMPP.messageFrom = Just from,
		XMPP.messageTo = Just (XMPP.JID (Just toNode) _ _)
	} | Just bodyTxt <- getBody message,
	    Right toAddress <- parsedToNode =
		Just (fromMailbox,
	    Right toMailbox@(MIME.Mailbox _ toAddrSpec) <- parsedToNode =
		Right $ EmailWithEnvelope {
			emailEnvelopeFrom = fromAddrSpec,
			emailEnvelopeTo = toAddrSpec,
			emailMessage =
			set (MIME.headers . at (s"Message-ID")) (Just mid) $
			set (MIME.headers . at (s"References")) refs $
			typeHeaders message $
			set (MIME.headerTo MIME.defaultCharsets) [toAddress] $
			set (MIME.headerTo MIME.defaultCharsets)
				[MIME.Single toMailbox] $
			setFrom $
			set (MIME.headers . at (s"Jabber-ID")) jidHeader $
			set (MIME.headers . at (s"Subject")) subjectHeader $
			set MIME.headerDate (Just dateHeader) $
			MIME.createTextPlainMessage bodyTxt
		}
	| Left err <- parsedToNode = Left $
		messageError (
			errorPayload "cancel" "item-not-found"
			(fromString $ "Not a valid email address: " ++ err) []
		)
		message
	where
	mid = mkMessageID fromDomain now message
	refs = mkReferences message


@@ 254,8 279,11 @@ messageToEmail fromDomain now message@XMPP.Message {
	subjectHeader = MIME.encodeEncodedWords <$>
		(getSubject message <|> defaultSubject message)
	setFrom = set (MIME.headerFrom MIME.defaultCharsets) [fromMailbox]
	fromMailbox = jidToMailbox from fromDomain
	fromMailbox@(MIME.Mailbox _ fromAddrSpec) = jidToMailbox from fromDomain
	parsedToNode =
		MIME.parse (MIME.address MIME.defaultCharsets) unescapedToNode
		MIME.parse (MIME.mailbox MIME.defaultCharsets) unescapedToNode
	unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode
messageToEmail _ _ _ = Nothing
messageToEmail _ _ message = Left $
	messageError
	(errorPayload "modify" "bad-request" (s"Could not process message") [])
	message

M Util.hs => Util.hs +8 -0
@@ 102,6 102,14 @@ iqError payload iq = (iqReply (Just payload) iq) {
	XMPP.iqType = XMPP.IQError
}

messageError :: XML.Element -> XMPP.Message -> XMPP.Message
messageError payload message = message {
	XMPP.messageType = XMPP.MessageError,
	XMPP.messageFrom = XMPP.messageTo message,
	XMPP.messageTo = XMPP.messageFrom message,
	XMPP.messagePayloads = payload : XMPP.messagePayloads message
}

notImplemented :: XML.Element
notImplemented =
	errorPayload "cancel" "feature-not-implemented" (s"Unknown request") []

M gateway.hs => gateway.hs +1 -7
@@ 16,7 16,6 @@ import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP
import qualified Network.Protocol.XMPP.Internal as XMPP
import qualified Data.MIME             as MIME
import qualified Network.Mail.Mime     as Mail

import Util
import Router


@@ 79,12 78,7 @@ messageHandler ::
	-> XMPP.XMPP ()
messageHandler fromDomain message = do
	now <- liftIO getCurrentTime
	forM_ (messageToEmail fromDomain now message) $ \(from, mail) ->
		liftIO $ Mail.sendmailCustom "/usr/sbin/sendmail" [
			"-t", "-i",
			"-f", textToString $ decodeUtf8 $
				MIME.renderMailbox from
		] (MIME.renderMessage mail)
	either XMPP.putStanza sendEmail $ messageToEmail fromDomain now message

messageErrorHandler ::
	   STMMap.Map (Maybe Text) XMPP.IQ

M test/EmailTest.hs => test/EmailTest.hs +13 -12
@@ 4,6 4,7 @@ import Prelude ()
import BasicPrelude
import Test.Tasty.HUnit
import Test.QuickCheck.Instances ()
import Control.Error (hush)
import qualified Data.Time.Format as Time
import qualified Data.MIME as MIME
import qualified Data.XML.Types as XML


@@ 304,12 305,12 @@ unit_emailToStanzaDeepReply =

unit_messageToEmailChat :: IO ()
unit_messageToEmailChat =
	fmap (MIME.renderMessage . snd) (
	hush (fmap (MIME.renderMessage . emailMessage) (
		messageToEmail
		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
		date
		message
	)
	))
	@?=
	Just email
	where


@@ 344,12 345,12 @@ unit_messageToEmailChat =

unit_messageToEmailWithSubject :: IO ()
unit_messageToEmailWithSubject =
	fmap (MIME.renderMessage . snd) (
	hush (fmap (MIME.renderMessage . emailMessage) (
		messageToEmail
		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
		date
		message
	)
	))
	@?=
	Just email
	where


@@ 388,12 389,12 @@ unit_messageToEmailWithSubject =

unit_messageToEmailWithDelay :: IO ()
unit_messageToEmailWithDelay =
	fmap (MIME.renderMessage . snd) (
	hush (fmap (MIME.renderMessage . emailMessage) (
		messageToEmail
		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
		date
		message
	)
	))
	@?=
	Just email
	where


@@ 426,12 427,12 @@ unit_messageToEmailWithDelay =

unit_messageToEmailWithThread :: IO ()
unit_messageToEmailWithThread =
	fmap (MIME.renderMessage . snd) (
	hush (fmap (MIME.renderMessage . emailMessage) (
		messageToEmail
		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
		date
		message
	)
	))
	@?=
	Just email
	where


@@ 462,12 463,12 @@ unit_messageToEmailWithThread =

unit_messageToEmailWithCheoThread :: IO ()
unit_messageToEmailWithCheoThread =
	fmap (MIME.renderMessage . snd) (
	hush (fmap (MIME.renderMessage . emailMessage) (
		messageToEmail
		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
		date
		message
	)
	))
	@?=
	Just email
	where


@@ 502,12 503,12 @@ unit_messageToEmailWithCheoThread =

unit_messageToEmailWithDeepCheoThread :: IO ()
unit_messageToEmailWithDeepCheoThread =
	fmap (MIME.renderMessage . snd) (
	hush (fmap (MIME.renderMessage . emailMessage) (
		messageToEmail
		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
		date
		message
	)
	))
	@?=
	Just email
	where