From 80203ece1cdf324feb2e66c766b2f4ca3256d464 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Sat, 22 Feb 2020 21:56:41 -0500 Subject: [PATCH] Baseline bidirectional working for text bodies --- Email.hs | 50 +++++++++++++++++++++++++---- IQManager.hs | 28 +++++++++------- Router.hs | 15 +++++++++ Util.hs | 16 +++++++++ cheogram-smtp.cabal | 6 ++-- gateway.hs | 22 ++++++++++++- incoming-email.hs | 33 ++++++++++--------- test/EmailTest.hs | 75 +++++++++++++++++++++++++++++++++++++++++++ test/IQManagerTest.hs | 28 ++++++++++++++++ test/UtilTest.hs | 26 +++++++++++++++ 10 files changed, 264 insertions(+), 35 deletions(-) create mode 100644 test/IQManagerTest.hs diff --git a/Email.hs b/Email.hs index 4b4d759..4b192ad 100644 --- a/Email.hs +++ b/Email.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 diff --git a/IQManager.hs b/IQManager.hs index 559d2d8..a68e261 100644 --- a/IQManager.hs +++ b/IQManager.hs @@ -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) diff --git a/Router.hs b/Router.hs index b53a3aa..001cf01 100644 --- a/Router.hs +++ b/Router.hs @@ -21,6 +21,15 @@ runRouted routes = forever $ XMPP.getStanza >>= handle iqResultRoute routes iq 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 @@ -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 () } diff --git a/Util.hs b/Util.hs index f6dd2c1..3673a9d 100644 --- a/Util.hs +++ b/Util.hs @@ -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 diff --git a/cheogram-smtp.cabal b/cheogram-smtp.cabal index 7b2f699..17e0091 100644 --- a/cheogram-smtp.cabal +++ b/cheogram-smtp.cabal @@ -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, diff --git a/gateway.hs b/gateway.hs index 4175c42..f2fc536 100644 --- a/gateway.hs +++ b/gateway.hs @@ -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 } diff --git a/incoming-email.hs b/incoming-email.hs index fc73702..f908ba5 100644 --- a/incoming-email.hs +++ b/incoming-email.hs @@ -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 () diff --git a/test/EmailTest.hs b/test/EmailTest.hs index a680c69..042b947 100644 --- a/test/EmailTest.hs +++ b/test/EmailTest.hs @@ -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" + ] + ] + } diff --git a/test/IQManagerTest.hs b/test/IQManagerTest.hs new file mode 100644 index 0000000..a4369e0 --- /dev/null +++ b/test/IQManagerTest.hs @@ -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") + } diff --git a/test/UtilTest.hs b/test/UtilTest.hs index 3885973..895e101 100644 --- a/test/UtilTest.hs +++ b/test/UtilTest.hs @@ -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 -- 2.45.2