2 files changed, 31 insertions(+), 17 deletions(-)

M Email.hs
M gateway.hs

@@ 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

@@ 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
 		}