~singpolyma/cheogram-smtp

5250b035102327aa1f9fb415086a43aa2902d1d4 — Stephen Paul Weber 1 year, 6 months ago 7021b24
Extract and store email attachments and related media parts
4 files changed, 115 insertions(+), 30 deletions(-)

M Email.hs
M cheogram-smtp.cabal
M incoming-email.hs
M test/EmailTest.hs
M Email.hs => Email.hs +82 -12
@@ 9,9 9,16 @@ import Control.Error
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 Control.Lens (
		Lens', Const, Leftmost, filtered, firstOf, view, _Right,
		set, at, toListOf, has
	)
import qualified Control.Lens                    as Lens
import qualified Crypto.Hash                     as Hash
import qualified Data.IPLD.CID                   as CID
import qualified Data.ByteString.Char8           as C8
import qualified Data.Map.Strict                 as SMap
import qualified Data.CaseInsensitive            as CI
import qualified Data.Text                       as T
import qualified Data.Attoparsec.ByteString.Lazy as Atto
import qualified Data.MIME                       as MIME


@@ 21,10 28,34 @@ 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 Network.Mime                    as MIME
import qualified UnexceptionalIO.Trans           as UIO

import Util

-- Do not use uncommon file extensions for ambiguous MIME types
badExts :: [Text]
badExts = [
		s"mpg4", s"mp4v",
		s"mpga", s"m2a", s"m3a", s"mp2", s"mp2a",
		s"m1v", s"m2v", s"mpe"
	]

mimeTypeTuple :: ByteString -> (CI.CI ByteString, CI.CI ByteString)
mimeTypeTuple mimeBytes = (CI.mk typ, CI.mk sub)
	where
	[typ, sub] = C8.split '/' mimeBytes

mimeToExtMap :: SMap.Map (CI.CI ByteString, CI.CI ByteString) Text
mimeToExtMap = SMap.fromList $
	(\xs -> ((CI.mk $ s"audio", CI.mk $ s"amr"), s"amr") : xs) $
	mapMaybe (\(ext, mimeBytes) ->
		if ext `elem` badExts then
			Nothing
		else
			Just (mimeTypeTuple mimeBytes, ext)
	) $ SMap.toList MIME.defaultMimeMap

mboxFrom :: Atto.Parser ()
mboxFrom =
	Atto.string (encodeUtf8 $ s"From ") *>


@@ 46,6 77,22 @@ isTextPlain :: MIME.WireEntity -> Bool
isTextPlain = MIME.matchContentType (s"text") (Just $ s"plain") .
	view MIME.contentType

getAttachmentsAndMedia :: (Monoid a) =>
	   ((MIME.ContentType, ByteString)
	    -> Const a (MIME.ContentType, ByteString))
	-> MIME.MIMEMessage -> Const a MIME.MIMEMessage
getAttachmentsAndMedia = MIME.entities . filtered (\part ->
		MIME.isAttachment part || has (MIME.contentType .
			filtered (\(MIME.ContentType t sub _) ->
				t /= s"text" &&
				not (t == s"application" && sub == s"smil")
			)
		) part
	) . Lens.to (liftA2 (,)
		(view MIME.contentType)
		(view (MIME.transferDecoded' . _Right . MIME.body))
	)

getEmailBody ::
	   (Text -> Const (Leftmost Text) Text)
	-> MIME.WireEntity


@@ 178,20 225,43 @@ emailToSubject = fmap (mkElement (s"{jabber:component:accept}subject")) .: go
	go XMPP.MessageChat = chatEmailSubject
	go _ = emailSubject

bytesToCid :: ByteString -> CID.CID
bytesToCid = CID.newCidV1 CID.Raw . Hash.hashWith Hash.SHA512

emailToStanza ::
	   Text
	-> Text
	-> MIME.MIMEMessage
	-> XMPP.Message
emailToStanza domain email =
	(XMPP.emptyMessage typ) {
		XMPP.messageFrom = mailboxToJID domain fromMailbox,
		XMPP.messagePayloads = [
			XML.Element (s"{jabber:component:accept}body") []
				[XML.NodeContent $ XML.ContentText textBody]
		] ++ subject ++ nick ++ mid ++
		maybeToList (emailToThread domain email)
	}
	-> (XMPP.Message, [(CID.CID, ByteString)])
emailToStanza domain attachmentUrl email = (
		(XMPP.emptyMessage typ) {
			XMPP.messageFrom = mailboxToJID domain fromMailbox,
			XMPP.messagePayloads = [
				XML.Element (s"{jabber:component:accept}body")
				[] [XML.NodeContent $ XML.ContentText textBody]
			] ++ subject ++ nick ++ mid ++ attachmentsOOB ++
			maybeToList (emailToThread domain email)
		},
		map (\(_, cid, bytes) -> (cid, bytes)) attachments
	)
	where
	attachments = map (\(ct, bytes) -> (ct, bytesToCid bytes, bytes)) $
		toListOf getAttachmentsAndMedia email
	attachmentsOOB = map (\(MIME.ContentType t sub _, cid, _) ->
			let extSuffix =
				maybe mempty (s"." ++) $
				SMap.lookup (t, sub) mimeToExtMap
			in
				XML.Element (s"{jabber:x:oob}x") [] [
					XML.NodeElement $
					XML.Element (s"{jabber:x:oob}url") [] [
						XML.NodeContent $
						XML.ContentText $
						attachmentUrl ++
						CID.cidToText cid ++ extSuffix
					]
				]
		) attachments
	typ = emailToMessageType email
	subject = maybeToList $ emailToSubject typ email
	mid = maybeToList $ emailToOriginID email

M cheogram-smtp.cabal => cheogram-smtp.cabal +8 -4
@@ 12,20 12,24 @@ build-type:          Simple
common defs
  default-language:    Haskell2010
  ghc-options:         -Wall -Wno-tabs -Wno-orphans -Werror
  build-depends:       base                  >=4.11 && <4.12,
  build-depends:       base                  >=4.11 && <4.14,
                       attoparsec            >=0.13 && <0.14,
                       basic-prelude         >=0.7 && <0.8,
                       bytestring            >=0.10 && <0.11,
                       containers            >=0.5 && <0.6,
                       containers            >=0.5 && <0.7,
                       case-insensitive      >=1.2 && <1.3,
                       cryptonite            >=0.25 && <0.30,
                       errors                >=2.3 && <2.4,
                       focus                 >= 1.0.1 && < 1.1,
                       lens                  >=4.16 && <4.17,
                       ipld-cid              >= 0.1 && < 0.2,
                       lens                  >=4.16 && <4.19,
                       mime-mail             >=0.4 && < 0.5,
                       mime-types            >=0.1 && < 0.2,
                       network               >= 2.6.3 && < 2.7,
                       network-protocol-xmpp >=0.4 && <0.5,
                       network-uri           >=2.6 && <2.7,
                       purebred-email        >=0.4.1 && <0.5,
                       stm                   >=2.4 && <2.5,
                       stm                   >=2.4 && <2.6,
                       stm-containers        >= 1.1.0 && < 1.2,
                       stm-delay             >=0.1 && <0.2,
                       text                  >=1.2 && <1.3,

M incoming-email.hs => incoming-email.hs +16 -5
@@ 7,6 7,8 @@ import Control.Concurrent.STM          (atomically)
import Control.Error                   (hush)
import Network                         (PortID (PortNumber))
import System.Exit                     (exitFailure)
import qualified Data.IPLD.CID         as CID
import qualified Data.ByteString       as ByteString
import qualified Data.ByteString.Lazy  as LByteString
import qualified Data.MIME             as MIME
import qualified Network.Protocol.XMPP as XMPP


@@ 30,8 32,14 @@ runClient jid =

main :: IO ()
main = do
	(rpcJidStr:rpcPassword:domain:envelopeTos) <- getArgs
	(rpcJidStr:rpcPassword:
	 domain:uploadUrl:uploadPath:
	 envelopeTos
	 ) <- getArgs
	let Just rpcJid = XMPP.parseJID rpcJidStr
	let cidToPath cid =
		textToString uploadPath ++ "/" ++
		textToString (CID.cidToText cid)

	let Just recipientJids = forM envelopeTos $ \envelopeTo ->
		(XMPP.parseJID =<<) $ fmap mailboxNode $ hush $ MIME.parse


@@ 41,11 49,14 @@ main = do
	input <- LByteString.getContents
	let Right email = MIME.parse messageOptionalMboxFrom input
	let messages = recipientJids <&> \recipientJid ->
		(emailToStanza domain email) {
			XMPP.messageTo = Just recipientJid
		}
		let (m, as) = emailToStanza domain uploadUrl email in
		(m { XMPP.messageTo = Just recipientJid }, as)

	messageIQs <- forM messages $ \(message, attachments) -> do
		forM_ attachments $ \(cid, bytes) ->
			ByteString.writeFile (cidToPath cid) bytes

	let messageIQs = messages <&> \message -> (XMPP.emptyIQ XMPP.IQSet) {
		return $ (XMPP.emptyIQ XMPP.IQSet) {
			XMPP.iqTo = XMPP.parseJID domain,
			XMPP.iqPayload = Just $ XMPP.stanzaToElement message
		}

M test/EmailTest.hs => test/EmailTest.hs +9 -9
@@ 42,7 42,7 @@ unit_mailboxToJID =

unit_emailToStanzaSimple :: IO ()
unit_emailToStanzaSimple =
	show (emailToStanza (s"gateway.example.com") message)
	show (fst $ emailToStanza (s"gateway.example.com") (s"/") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageNormal) {
		XMPP.messageFrom =


@@ 79,7 79,7 @@ unit_emailToStanzaSimple =

unit_emailToStanzaChat :: IO ()
unit_emailToStanzaChat =
	show (emailToStanza (s"gateway.example.com") message)
	show (fst $ emailToStanza (s"gateway.example.com") (s"/") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageChat) {
		XMPP.messageFrom =


@@ 104,7 104,7 @@ unit_emailToStanzaChat =

unit_emailToStanzaChatFakeSubject :: IO ()
unit_emailToStanzaChatFakeSubject =
	show (emailToStanza (s"gateway.example.com") message)
	show (fst $ emailToStanza (s"gateway.example.com") (s"/") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageChat) {
		XMPP.messageFrom =


@@ 126,7 126,7 @@ unit_emailToStanzaChatFakeSubject =

unit_emailToStanzaChatReFakeSubject :: IO ()
unit_emailToStanzaChatReFakeSubject =
	show (emailToStanza (s"gateway.example.com") message)
	show (fst $ emailToStanza (s"gateway.example.com") (s"/") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageChat) {
		XMPP.messageFrom =


@@ 148,7 148,7 @@ unit_emailToStanzaChatReFakeSubject =

unit_emailToStanzUTF8Subject :: IO ()
unit_emailToStanzUTF8Subject =
	show (emailToStanza (s"gateway.example.com") message)
	show (fst $ emailToStanza (s"gateway.example.com") (s"/") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageNormal) {
		XMPP.messageFrom =


@@ 170,7 170,7 @@ unit_emailToStanzUTF8Subject =

unit_emailToStanzaReply :: IO ()
unit_emailToStanzaReply =
	show (emailToStanza (s"gateway.example.com") message)
	show (fst $ emailToStanza (s"gateway.example.com") (s"/") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageNormal) {
		XMPP.messageFrom =


@@ 209,7 209,7 @@ unit_emailToStanzaReply =

unit_emailToStanzaReplyNulThread :: IO ()
unit_emailToStanzaReplyNulThread =
	show (emailToStanza (s"gateway.example.com") message)
	show (fst $ emailToStanza (s"gateway.example.com") (s"/") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageNormal) {
		XMPP.messageFrom =


@@ 245,7 245,7 @@ unit_emailToStanzaReplyNulThread =

unit_emailToStanzaDeepReply:: IO ()
unit_emailToStanzaDeepReply =
	show (emailToStanza (s"gateway.example.com") message)
	show (fst $ emailToStanza (s"gateway.example.com") (s"/") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageNormal) {
		XMPP.messageFrom =


@@ 305,7 305,7 @@ unit_emailToStanzaDeepReply =

unit_emailToStanzaDeepInReplyTo:: IO ()
unit_emailToStanzaDeepInReplyTo =
	show (emailToStanza (s"gateway.example.com") message)
	show (fst $ emailToStanza (s"gateway.example.com") (s"/") message)
	@?=
	show (XMPP.emptyMessage XMPP.MessageNormal) {
		XMPP.messageFrom =