10 files changed, 264 insertions(+), 35 deletions(-)

M Email.hs
M IQManager.hs
M Router.hs
M Util.hs
M cheogram-smtp.cabal
M gateway.hs
M incoming-email.hs
M test/EmailTest.hs
A test/IQManagerTest.hs
M test/UtilTest.hs

@@ 2,9 2,10 @@ module Email where
 
 import BasicPrelude
 import Prelude ()
+import Data.Char                                 (isAscii, isAlphaNum)
 import Control.Error                             (headZ)
 import Control.Lens 
-	(Const, Leftmost, filtered, firstOf, view, _Right)
+	(Const, Leftmost, filtered, firstOf, view, _Right, set, at)
 import qualified Data.Attoparsec.ByteString.Lazy as Atto
 import qualified Data.ByteString                 as ByteString
 import qualified Data.ByteString.Builder         as Builder


@@ 12,6 13,7 @@ import qualified Data.ByteString.Lazy            as LByteString
 import qualified Data.List.NonEmpty
 import qualified Data.MIME                       as MIME
 import qualified Data.MIME.Charset               as MIME
+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


@@ 25,19 27,18 @@ mboxFrom =
 	MIME.crlf *>
 	pure ()
 
-messageOptionalMboxFrom ::
-	Atto.Parser (MIME.Message MIME.EncStateWire MIME.MIME)
+messageOptionalMboxFrom :: Atto.Parser MIME.MIMEMessage
 messageOptionalMboxFrom = Atto.option () mboxFrom *> MIME.message MIME.mime
 
 isTextPlain :: MIME.WireEntity -> Bool
 isTextPlain = MIME.matchContentType (s"text") (Just $ s"plain") .
 	view MIME.contentType
 
-getBody ::
+getEmailBody ::
 	   (Text -> Const (Leftmost Text) Text)
 	-> MIME.WireEntity
 	-> Const (Leftmost Text) MIME.WireEntity
-getBody = MIME.transferDecoded' . _Right .
+getEmailBody = MIME.transferDecoded' . _Right .
 	MIME.charsetPrism MIME.defaultCharsets .
 	filtered (not . MIME.isAttachment) .
 	MIME.body


@@ 46,7 47,7 @@ plainTextBody ::
 	   (Text -> Const (Leftmost Text) Text)
 	-> MIME.MIMEMessage
 	-> Const (Leftmost Text) MIME.MIMEMessage
-plainTextBody = MIME.entities . filtered isTextPlain . getBody
+plainTextBody = MIME.entities . filtered isTextPlain . getEmailBody
 
 mailboxNode :: MIME.Mailbox -> Text
 mailboxNode (MIME.Mailbox _ (MIME.AddrSpec local _)) =


@@ 59,6 60,22 @@ mailboxToJID domain (MIME.Mailbox _ addrspec) =
 	addr = decodeUtf8 $ LByteString.toStrict $ Builder.toLazyByteString $
 		renderAddressSpec addrspec
 
+-- Always escapes % for now
+-- Always escapes . for now
+unescapedInEmailLocalpart :: Char -> Bool
+unescapedInEmailLocalpart c = isAscii c &&
+	(isAlphaNum c || c `elem` "!#$&'*+-/=?^_`{|}~")
+
+jidToLocalpart :: XMPP.JID -> ByteString
+jidToLocalpart jid = encodeUtf8 $ fromString $
+	URI.escapeURIString unescapedInEmailLocalpart bareStr
+	where
+	bareStr = textToString $ bareTxt jid
+
+jidToMailbox :: XMPP.JID -> MIME.Domain -> MIME.Mailbox
+jidToMailbox jid domain = MIME.Mailbox Nothing $
+	MIME.AddrSpec (jidToLocalpart jid) domain
+
 emailToStanza ::
 	   (MIME.Mailbox -> Maybe XMPP.JID)
 	-> MIME.MIMEMessage


@@ 79,6 96,27 @@ emailToStanza toJid email =
 		firstOf (MIME.headers . MIME.header (s"subject")) email
 	Just from = toJid =<< headZ =<< firstOf MIME.headerFrom email
 
+messageToEmail ::
+	   MIME.Domain
+	-> XMPP.Message
+	-> Maybe (MIME.Mailbox, MIME.MIMEMessage)
+messageToEmail fromDomain message@XMPP.Message {
+		XMPP.messageFrom = Just from,
+		XMPP.messageTo = Just (XMPP.JID (Just toNode) _ _)
+	} | Just bodyTxt <- getBody message,
+	    Right toAddress <- MIME.parse MIME.address unescapedToNode =
+		Just (fromMailbox,
+			set MIME.headerTo [toAddress] $
+			set MIME.headerFrom [fromMailbox] $
+			set (MIME.headers . at (s"Subject")) subjectHeader $
+			MIME.createTextPlainMessage bodyTxt
+		)
+	where
+	subjectHeader = MIME.encodeEncodedWords <$> getSubject message
+	fromMailbox = jidToMailbox from fromDomain
+	unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode
+messageToEmail _ _ = Nothing
+
 -- copied from purebred-email
 -- See https://github.com/purebred-mua/purebred-email/issues/39
 renderAddressSpec :: MIME.AddrSpec -> Builder.Builder

@@ 1,4 1,4 @@
-module IQManager (iqManager) where
+module IQManager (iqManager, iqManager') where
 
 import Prelude ()
 import BasicPrelude


@@ 28,20 28,20 @@ iqSenderUnexceptional responseMapVar iqToSend = do
 	atomicUIO $ modifyTVar' responseMapVar $
 			Map.insert (XMPP.iqID iqToSend) iqResponseVar
 	return (
-			waitDelay timeout *> pure Nothing
+			(waitDelay timeout *> pure Nothing)
 			`orElse`
 			fmap Just (takeTMVar iqResponseVar)
 		)
 
 iqSender ::
-	   TVar ResponseMap
+	  (XMPP.IQ -> XMPP.XMPP a)
 	-> XMPP.IQ
-	-> XMPP.XMPP (STM (Maybe XMPP.IQ))
-iqSender responseMapVar iqToSend
+	-> XMPP.XMPP a
+iqSender baseSender iqToSend
 	| XMPP.iqType iqToSend `elem` [XMPP.IQGet, XMPP.IQSet] = do
-		resultGetter <- iqSenderUnexceptional responseMapVar iqToSend
+		result <- baseSender iqToSend
 		XMPP.putStanza iqToSend
-		return resultGetter
+		return result
 	| otherwise = error "iqManager can only send IQGet or IQSet"
 
 iqReceiver :: (Unexceptional m) => TVar ResponseMap -> XMPP.IQ -> m ()


@@ 59,11 59,17 @@ iqReceiver responseMapVar receivedIQ
 			atomicUIO $ tryPutTMVar iqResponseVar receivedIQ
 	| otherwise = return () -- TODO: log or otherwise signal error?
 
-iqManager :: (Unexceptional m1, Unexceptional m2) =>
-	m1 (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ)), XMPP.IQ -> m2 ())
-iqManager = do
+iqManager' :: (Unexceptional m1, Unexceptional m2, Unexceptional m3) =>
+	m1 (XMPP.IQ -> m2 (STM (Maybe XMPP.IQ)), XMPP.IQ -> m3 ())
+iqManager' = do
 	responseMapVar <- atomicUIO $ newTVar Map.empty
 	return (
-			iqSender responseMapVar,
+			iqSenderUnexceptional responseMapVar,
 			iqReceiver responseMapVar
 		)
+
+iqManager :: (Unexceptional m1, Unexceptional m2) =>
+	m1 (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ)), XMPP.IQ -> m2 ())
+iqManager = do
+	(sender, receiver) <- iqManager'
+	return (iqSender sender, receiver)

@@ 22,6 22,15 @@ runRouted routes = forever $ XMPP.getStanza >>= handle
 	handle (XMPP.ReceivedIQ iq@XMPP.IQ { XMPP.iqType = XMPP.IQError }) =
 		iqErrorRoute routes iq
 	handle (XMPP.ReceivedMessage message@XMPP.Message {
+		XMPP.messageType = XMPP.MessageNormal
+	}) = messageNormalRoute routes message
+	handle (XMPP.ReceivedMessage message@XMPP.Message {
+		XMPP.messageType = XMPP.MessageChat
+	}) = messageChatRoute routes message
+	handle (XMPP.ReceivedMessage message@XMPP.Message {
+		XMPP.messageType = XMPP.MessageHeadline
+	}) = messageHeadlineRoute routes message
+	handle (XMPP.ReceivedMessage message@XMPP.Message {
 		XMPP.messageType = XMPP.MessageError
 	}) = messageErrorRoute routes message
 	handle _ = return ()


@@ 31,6 40,9 @@ data Routes = Routes {
 	iqSetRoute :: XMPP.IQ -> XMPP.XMPP (),
 	iqResultRoute :: XMPP.IQ -> XMPP.XMPP (),
 	iqErrorRoute :: XMPP.IQ -> XMPP.XMPP (),
+	messageNormalRoute :: XMPP.Message -> XMPP.XMPP (),
+	messageChatRoute :: XMPP.Message -> XMPP.XMPP (),
+	messageHeadlineRoute :: XMPP.Message -> XMPP.XMPP (),
 	messageErrorRoute :: XMPP.Message -> XMPP.XMPP ()
 }
 


@@ 40,5 52,8 @@ defaultRoutes = Routes {
 	iqSetRoute = XMPP.putStanza . iqError notImplemented,
 	iqResultRoute = const $ return (),
 	iqErrorRoute = const $ return (),
+	messageNormalRoute = const $ return (),
+	messageChatRoute = const $ return (),
+	messageHeadlineRoute = const $ return (),
 	messageErrorRoute = const $ return ()
 }

@@ 108,6 108,14 @@ child name = listToMaybe .
 errorChild :: (XMPP.Stanza s) => s -> Maybe XML.Element
 errorChild = child (s"{jabber:component:accept}error")
 
+getBody :: (XMPP.Stanza s) => s -> Maybe Text
+getBody = fmap (mconcat . XML.elementText) .
+	child (s"{jabber:component:accept}body")
+
+getSubject :: (XMPP.Stanza s) => s -> Maybe Text
+getSubject = fmap (mconcat . XML.elementText) .
+	child (s"{jabber:component:accept}subject")
+
 errorPayload :: String -> String -> Text -> [XML.Node] -> XML.Element
 errorPayload typ definedCondition english morePayload =
 	XML.Element (s"{jabber:component:accept}error")


@@ 127,3 135,11 @@ errorPayload typ definedCondition english morePayload =
 	where
 	definedConditionName = fromString $
 		"{urn:ietf:params:xml:ns:xmpp-stanzas}" ++ definedCondition
+
+bareJid :: XMPP.JID -> XMPP.JID
+bareJid (XMPP.JID node domain _) = XMPP.JID node domain Nothing
+
+bareTxt :: XMPP.JID -> Text
+bareTxt (XMPP.JID (Just node) domain _) =
+	mconcat [XMPP.strNode node, s"@", XMPP.strDomain domain]
+bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain

@@ 20,6 20,7 @@ common defs
                        errors                >=2.3 && <2.4,
                        focus                 >= 1.0.1 && < 1.1,
                        lens                  >=4.16 && <4.17,
+                       mime-mail             >=0.4 && < 0.5,
                        network               >= 2.6.3 && < 2.7,
                        network-protocol-xmpp >=0.4 && <0.5,
                        network-uri           >=2.6 && <2.7,


@@ 35,7 36,7 @@ common defs
 executable gateway
   import:              defs
   main-is:             gateway.hs
-  other-modules:       Router, Util
+  other-modules:       Router, Util, Email
 
 executable incoming-email
   import:              defs


@@ 47,7 48,8 @@ test-suite test
   main-is:             Driver.hs
   type:                exitcode-stdio-1.0
   hs-source-dirs:      ., test
-  other-modules:       UtilTest, EmailTest, TestInstances, Util, Email
+  other-modules:       UtilTest, EmailTest, TestInstances, Util, Email,
+                       IQManager, IQManagerTest
   build-depends:       tasty,
                        tasty-hunit,
                        tasty-quickcheck,

@@ 5,6 5,7 @@ import BasicPrelude
 import Control.Concurrent              (threadDelay)
 import Control.Error                   (exceptT)
 import Network                         (PortID (PortNumber))
+import qualified Data.ByteString.Lazy  as LByteString
 import qualified Focus
 import qualified StmContainers.Map     as STMMap
 import qualified Data.UUID             as UUID


@@ 12,9 13,12 @@ import qualified Data.UUID.V4          as UUID
 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
+import Email
 
 newtype RawComponentStanza = RawComponentStanza XML.Element
 


@@ 53,7 57,7 @@ iqSetHandler replyMap componentJid trustedJids iq@XMPP.IQ {
 		XMPP.iqFrom = Just from,
 		XMPP.iqTo = Just to,
 		XMPP.iqPayload = payload
-	} | to == componentJid && from `elem` trustedJids = do
+	} | to == componentJid && bareJid from `elem` trustedJids = do
 		uuid <- liftIO UUID.nextRandom
 		let sid = UUID.toText uuid
 		atomicUIO $ STMMap.insert iq (Just sid) replyMap


@@ 67,6 71,18 @@ iqSetHandler replyMap componentJid trustedJids iq@XMPP.IQ {
 				XMPP.putStanza $ iqReply Nothing originalIQ
 iqSetHandler _ _ _ iq = XMPP.putStanza $ iqError notImplemented iq
 
+messageHandler ::
+	   MIME.Domain
+	-> XMPP.Message
+	-> XMPP.XMPP ()
+messageHandler fromDomain message =
+	forM_ (messageToEmail fromDomain message) $ \(from, mail) ->
+		liftIO $ Mail.sendmailCustom "/usr/sbin/sendmail" [
+			"-t", "-i",
+			"-f", textToString $ decodeUtf8 $
+				MIME.renderMailbox from
+		] (LByteString.fromStrict $ MIME.renderMessage mail)
+
 messageErrorHandler ::
 	   STMMap.Map (Maybe Text) XMPP.IQ
 	-> XMPP.Message


@@ 82,6 98,8 @@ messageErrorHandler replyMap message = do
 main :: IO ()
 main = do
 	(componentJidTxt:host:portTxt:secret:trustedJidsTxt) <- getArgs
+	let Right (MIME.Mailbox _ (MIME.AddrSpec _ emailDomain)) =
+		MIME.parse MIME.mailbox (s"boop@" ++ encodeUtf8 componentJidTxt)
 	let Just componentJid = XMPP.parseJID componentJidTxt
 	let Just trustedJids = mapM XMPP.parseJID trustedJidsTxt
 	let port = PortNumber $ read portTxt


@@ 91,6 109,8 @@ main = do
 	exceptT print return $ runRoutedComponent server secret $ defaultRoutes{
 			iqSetRoute =
 				iqSetHandler replyMap componentJid trustedJids,
+			messageNormalRoute = messageHandler emailDomain,
+			messageChatRoute = messageHandler emailDomain,
 			messageErrorRoute =
 				messageErrorHandler replyMap
 		}

@@ 2,6 2,7 @@ module Main (main) where
 
 import Prelude ()
 import BasicPrelude
+import Data.Functor                    ((<&>))
 import Control.Concurrent.STM          (atomically)
 import Control.Error                   (hush)
 import Network                         (PortID (PortNumber))


@@ 29,21 30,23 @@ runClient jid =
 
 main :: IO ()
 main = do
-	[rpcJidStr, rpcPassword, domain, envelopeTo] <- getArgs
+	(rpcJidStr:rpcPassword:domain:envelopeTos) <- getArgs
 	let Just rpcJid = XMPP.parseJID rpcJidStr
 
-	let Just recipientJid = XMPP.parseJID =<< mailboxNode <$>
-		hush (MIME.parse MIME.mailbox $ encodeUtf8 envelopeTo)
+	let Just recipientJids = forM envelopeTos $ \envelopeTo ->
+		XMPP.parseJID =<< mailboxNode <$>
+			hush (MIME.parse MIME.mailbox $ encodeUtf8 envelopeTo)
 
 	input <- LByteString.getContents
 	let Right email = MIME.parse messageOptionalMboxFrom input
-	let message = (emailToStanza (mailboxToJID domain) email) {
+	let messages = recipientJids <&> \recipientJid ->
+		(emailToStanza (mailboxToJID domain) email) {
 			XMPP.messageTo = Just recipientJid
 		}
 
-	let messageIQ = (XMPP.emptyIQ XMPP.IQSet) {
+	let messageIQs = messages <&> \message -> (XMPP.emptyIQ XMPP.IQSet) {
 			XMPP.iqTo = XMPP.parseJID domain,
-			XMPP.iqID = Just $ s"theOnlyOne",
+			XMPP.iqID = bareTxt <$> XMPP.messageTo message,
 			XMPP.iqPayload = Just $ XMPP.stanzaToElement message
 		}
 


@@ 55,19 58,19 @@ main = do
 				iqErrorRoute = iqReceived
 			}
 
-		resultSTM <- sendIQ messageIQ
-		result <- liftIO $ atomically resultSTM
-		liftIO $ case result of
+		resultsSTM <- mapM sendIQ messageIQs
+		result <- liftIO $ atomically (sequence resultsSTM)
+		liftIO $ case sequence result of
 			Nothing -> do
-				putStrLn $ s"450 Delivery timed out"
+				putStrLn $ s"4.5.0 Delivery timed out"
 				exitFailure
-			Just iq | XMPP.iqType iq == XMPP.IQResult ->
+			Just iqs | all ((==XMPP.IQResult) . XMPP.iqType) iqs ->
 				return ()
-			Just iq -> do
-				putStrLn $ s"550 Delivery error"
-				print $ XMPP.iqPayload iq
+			Just iqs -> do
+				putStrLn $ s"5.5.0 Delivery error"
+				print $ map XMPP.iqPayload iqs
 				exitFailure
 
 	case result of
-		Left e -> print e
+		Left e -> print e >> exitFailure
 		_ -> return ()

@@ 11,6 11,7 @@ import qualified Network.Protocol.XMPP as XMPP
 
 import Util
 import Email
+import TestInstances ()
 
 mailboxFromLocal :: Text -> MIME.Mailbox
 mailboxFromLocal local = MIME.Mailbox Nothing $


@@ 22,6 23,12 @@ prop_mailboxNode local =
 	where
 	unEscapedLocal = fromString $ URI.unEscapeString $ textToString local
 
+prop_jidToMailboxRoundtrip :: XMPP.JID -> MIME.Domain -> Bool
+prop_jidToMailboxRoundtrip jid domain =
+	mailboxNode mailbox == bareTxt jid
+	where
+	mailbox = jidToMailbox jid domain
+
 unit_mailboxNodeUnescapes :: IO ()
 unit_mailboxNodeUnescapes =
 	mailboxNode (mailboxFromLocal $ s"boop%40example.com")


@@ 82,3 89,71 @@ unit_emailToStanzUTF8Subject =
 	\Subject: =?utf-8?B?5LiW55WM?=\n\
 	\\n\
 	\Hello\n"
+
+unit_messageToEmail :: IO ()
+unit_messageToEmail =
+	fmap (MIME.renderMessage . snd) (
+		messageToEmail
+		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
+		message
+	)
+	@?=
+	Just email
+	where
+	email = s"MIME-Version: 1.0\r\n\
+	\To: t@example.com\r\n\
+	\From: f%40example%2Ecom@gateway.example.com\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) {
+		XMPP.messageTo =
+			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
+		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
+		XMPP.messagePayloads = [
+			XML.Element (fromString "{jabber:component:accept}body")
+			[] [
+				XML.NodeContent $ XML.ContentText $
+					s"世界\n.\n"
+			]
+		]
+	}
+
+unit_messageToEmailWithSubject :: IO ()
+unit_messageToEmailWithSubject =
+	fmap (MIME.renderMessage . snd) (
+		messageToEmail
+		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
+		message
+	)
+	@?=
+	Just email
+	where
+	email = s"MIME-Version: 1.0\r\n\
+	\To: t@example.com\r\n\
+	\From: f%40example%2Ecom@gateway.example.com\r\n\
+	\Subject: =?utf-8?B?5LiW55WM?=\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) {
+		XMPP.messageTo =
+			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
+		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
+		XMPP.messagePayloads = [
+			XML.Element
+			(fromString "{jabber:component:accept}subject") [] [
+				XML.NodeContent $ XML.ContentText $
+					s"世界"
+			],
+			XML.Element
+			(fromString "{jabber:component:accept}body") [] [
+				XML.NodeContent $ XML.ContentText $
+					s"世界\n.\n"
+			]
+		]
+	}

@@ 0,0 1,28 @@
+module IQManagerTest where
+
+import Prelude ()
+import BasicPrelude
+import Control.Concurrent.STM (atomically)
+import Test.Tasty.HUnit
+import Test.QuickCheck.Instances ()
+import qualified Network.Protocol.XMPP as XMPP
+import qualified Network.Protocol.XMPP.Internal as XMPP
+
+import Util
+import IQManager
+
+unit_iqManager :: IO ()
+unit_iqManager = do
+	(sendIQ, iqReceived) <- iqManager'
+	stm <- sendIQ iqToSend
+	iqReceived iqResult
+	result <- atomically stm
+	fmap XMPP.stanzaToElement result @?=
+		(Just $ XMPP.stanzaToElement iqResult)
+	where
+	iqToSend = (XMPP.emptyIQ XMPP.IQSet) {
+		XMPP.iqID = Just (s"theID")
+	}
+	iqResult = (XMPP.emptyIQ XMPP.IQResult) {
+		XMPP.iqID = Just (s"theID")
+	}

@@ 37,6 37,32 @@ prop_iqError iq =
 	where
 	err = iqError exampleElement iq
 
+prop_getBody :: Text -> Bool
+prop_getBody bodyTxt = getBody message == Just bodyTxt
+	where
+	message = (XMPP.emptyMessage XMPP.MessageNormal) {
+		XMPP.messagePayloads = [
+			exampleElement,
+			XML.Element (s"{jabber:component:accept}body") [] [
+				XML.NodeContent $ XML.ContentText mempty,
+				XML.NodeContent $ XML.ContentText bodyTxt
+			]
+		]
+	}
+
+prop_getSubject :: Text -> Bool
+prop_getSubject subjectTxt = getSubject message == Just subjectTxt
+	where
+	message = (XMPP.emptyMessage XMPP.MessageNormal) {
+		XMPP.messagePayloads = [
+			exampleElement,
+			XML.Element (s"{jabber:component:accept}subject") [] [
+				XML.NodeContent $ XML.ContentText mempty,
+				XML.NodeContent $ XML.ContentText subjectTxt
+			]
+		]
+	}
+
 unit_childFound :: IO ()
 unit_childFound =
 	child (s"{findme.example.com}x") message