~singpolyma/cheogram-smtp: Return XMPP error when message cannot be sent as email

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