~singpolyma/cheogram-smtp

0abb8adc17a553862159c27b55911112cc4f7d38 — Stephen Paul Weber 2 years ago 5d17364
Return XMPP error when sendmail fails. Allow using a custom sendmail script
2 files changed, 31 insertions(+), 17 deletions(-)

M Email.hs
M gateway.hs
M Email.hs => Email.hs +8 -4
@@ 4,9 4,11 @@ import BasicPrelude
import Prelude ()
import Data.Char                                 (isAscii, isAlphaNum)
import Data.Functor                              ((<&>))
import Control.Error                             (headZ, lastZ, justZ, hush)
import Control.Error
	(headZ, lastZ, justZ, hush, exceptT)
import Data.Time.Clock                           (UTCTime)
import Data.Time.Format                          (formatTime, defaultTimeLocale)
import Control.Exception                         (ErrorCall(..))
import Control.Lens
	(Lens', Const, Leftmost, filtered, firstOf, view, _Right, set, at)
import qualified Data.ByteString.Char8           as C8


@@ 19,6 21,7 @@ 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 qualified UnexceptionalIO.Trans           as UIO

import Util



@@ 242,9 245,10 @@ emailMessage' :: Lens' EmailWithEnvelope MIME.MIMEMessage
emailMessage' f (EmailWithEnvelope msg from to) =
	fmap (\msg' -> EmailWithEnvelope msg' from to) (f msg)

sendEmail :: (MonadIO m) => EmailWithEnvelope -> m ()
sendEmail (EmailWithEnvelope mail from to) =
	liftIO $ Mail.sendmailCustom "/usr/sbin/sendmail" [
sendEmail :: (UIO.Unexceptional m) => String -> EmailWithEnvelope -> m Bool
sendEmail sendmail (EmailWithEnvelope mail from to) =
	exceptT (\(ErrorCall _) -> return False) (const $ return True) $
	UIO.fromIO' (error . show) $ Mail.sendmailCustom sendmail [
		"-i",
		"-f", textToString $ decodeUtf8 $ MIME.renderAddressSpec from,
		"--", textToString $ decodeUtf8 $ MIME.renderAddressSpec to

M gateway.hs => gateway.hs +23 -13
@@ 6,7 6,7 @@ import System.IO
	(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Control.Concurrent              (threadDelay)
import Control.Concurrent.STM          (STM)
import Control.Error                   (exceptT, headZ)
import Control.Error                   (exceptT, ExceptT(..), headZ, throwE)
import Control.Lens                    (over, set, at, _Right, traverseOf)
import Network                         (PortID (PortNumber))
import Data.Time.Clock                 (getCurrentTime)


@@ 99,21 99,28 @@ fetchAndAddVCardData sendIQ email from to =

messageHandler ::
	   MIME.Domain
	-> String
	-> (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ)))
	-> XMPP.Message
	-> XMPP.XMPP ()
messageHandler fromDomain sendIQ message@XMPP.Message {
messageHandler fromDomain sendmail sendIQ message@XMPP.Message {
	XMPP.messageFrom = from,
	XMPP.messageTo = to
} = do
	now <- liftIO getCurrentTime
	either XMPP.putStanza sendEmail =<< traverseOf (_Right . emailMessage')
		(\msg ->
			maybe (return msg)
			(fetchAndAddVCardData sendIQ msg to)
			from
		)
		(messageToEmail fromDomain now message)
	exceptT XMPP.putStanza return $ do
		email <- ExceptT $ traverseOf (_Right . emailMessage')
			(\msg ->
				maybe (return msg)
				(fetchAndAddVCardData sendIQ msg to)
				from
			)
			(messageToEmail fromDomain now message)
		result <- sendEmail sendmail email
		if result then return () else throwE $ messageError err message
	where
	err = errorPayload "cancel" "undefined-condition"
		(s"Could not send email (maybe matched SPAM filter?)") []

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


@@ 132,14 139,15 @@ main = do
	hSetBuffering stdout LineBuffering
	hSetBuffering stderr LineBuffering

	(componentJidTxt:host:portTxt:secret:trustedJidsTxt) <- getArgs
	(componentJidTxt:host:portTxt:secret:sendmailTxt:trustedTxt) <- getArgs
	let Right (MIME.Mailbox _ (MIME.AddrSpec _ emailDomain)) =
		MIME.parse (MIME.mailbox MIME.defaultCharsets)
		(s"boop@" ++ encodeUtf8 componentJidTxt)
	let Just componentJid = XMPP.parseJID componentJidTxt
	let Just trustedJids = mapM XMPP.parseJID trustedJidsTxt
	let Just trustedJids = mapM XMPP.parseJID trustedTxt
	let port = PortNumber $ read portTxt
	let server = XMPP.Server componentJid (textToString host) port
	let sendmail = textToString sendmailTxt

	replyMap <- STMMap.newIO
	exceptT print return $ runRoutedComponent server secret $ do


@@ 149,7 157,9 @@ main = do
				iqSetHandler replyMap componentJid trustedJids,
			iqResultRoute = iqReceived,
			iqErrorRoute = iqReceived,
			messageNormalRoute = messageHandler emailDomain sendIQ,
			messageChatRoute = messageHandler emailDomain sendIQ,
			messageNormalRoute =
				messageHandler emailDomain sendmail sendIQ,
			messageChatRoute =
				messageHandler emailDomain sendmail sendIQ,
			messageErrorRoute = messageErrorHandler replyMap
		}