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