~singpolyma/cheogram-smtp

80203ece1cdf324feb2e66c766b2f4ca3256d464 — Stephen Paul Weber 2 years ago 9d0d605
Baseline bidirectional working for text bodies
M Email.hs => Email.hs +44 -6
@@ 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

M IQManager.hs => IQManager.hs +17 -11
@@ 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)

M Router.hs => Router.hs +15 -0
@@ 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 ()
}

M Util.hs => Util.hs +16 -0
@@ 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

M cheogram-smtp.cabal => cheogram-smtp.cabal +4 -2
@@ 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,

M gateway.hs => gateway.hs +21 -1
@@ 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
		}

M incoming-email.hs => incoming-email.hs +18 -15
@@ 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 ()

M test/EmailTest.hs => test/EmailTest.hs +75 -0
@@ 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"
			]
		]
	}

A test/IQManagerTest.hs => test/IQManagerTest.hs +28 -0
@@ 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")
	}

M test/UtilTest.hs => test/UtilTest.hs +26 -0
@@ 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