~singpolyma/cheogram-smtp

324aca7cdb30fa0acea5abd8d1c908fa4027fcaf — Stephen Paul Weber 1 year, 2 months ago 32c4ef9
Convert MM4 mails to Bandwidth MMS JSON and send to a webhook
3 files changed, 137 insertions(+), 1 deletions(-)

A MMS.hs
M cheogram-smtp.cabal
A incoming-mms.hs
A MMS.hs => MMS.hs +91 -0
@@ 0,0 1,91 @@
module MMS where

import Prelude ()
import BasicPrelude

import Data.Char (isDigit)
import Data.Time (UTCTime)
import Data.Time.Format (parseTimeM, defaultTimeLocale, rfc822DateFormat)
import Network.URI (URI)
import Control.Error (hush, headZ)
import Control.Lens (firstOf)
import Data.Aeson ((.=))
import qualified Data.Aeson           as Aeson
import qualified Data.Attoparsec.Text as Atto
import qualified Data.IPLD.CID        as CID
import qualified Data.MIME            as MIME

import Email
import Util

newtype Tel = Tel Text deriving (Show)

instance Aeson.ToJSON Tel where
	toJSON (Tel tel) = Aeson.toJSON tel
	toEncoding (Tel tel) = Aeson.toEncoding tel

data MMS = MMS {
	mid :: Text,
	time :: UTCTime,
	to :: [Tel],
	from :: Tel,
	owner :: Tel, -- envelope to
	text :: Maybe Text,
	media :: [URI]
} deriving (Show)

instance Aeson.ToJSON MMS where
	toJSON mms = Aeson.object [
			s"type" .= "message-received",
			s"time" .= time mms,
			s"message" .= Aeson.object ([
					s"direction" .= "in",
					s"id" .= mid mms,
					s"to" .= to mms,
					s"from" .= from mms,
					s"owner" .= owner mms
				] ++
				maybe [] (\t -> [s"text" .= t]) (text mms) ++
				[
					s"media" .= map tshow (media mms) |
					not $ null (media mms)
				]
			)
		]

telParser :: Atto.Parser Tel
telParser = do
	_ <- Atto.char '+'
	tel <- Atto.takeWhile isDigit
	return $ Tel (s"+" ++ tel)

addressTel :: AddressLax -> Maybe Tel
addressTel (AddressLax addr) = hush $ Atto.parseOnly telParser addr
addressTel (Address addr) = headZ $
	mapMaybe (\(MIME.Mailbox _ addrspec) ->
		addressTel $ AddressLax $ decodeUtf8 $
		MIME.renderAddressSpec addrspec
	) (addressMailboxes addr)

emailToMMS ::
	   Text
	-> Text
	-> MIME.MIMEMessage
	-> Maybe (MMS, [(CID.CID, ByteString)])
emailToMMS attachmentUrl ownerT email = do
		mid' <- fmap decodeUtf8 $ header "x-internal-message-id"
		time' <- parseTimeM True defaultTimeLocale rfc822DateFormat .
			textToString . decodeUtf8 =<<
			header "date"
		from' <- addressTel =<<
			fmap (Address . MIME.Single) (fromMailbox email)
		owner' <- addressTel $ AddressLax ownerT
		return (MMS mid' time' to' from' owner' text' media', files)
	where
	media' = map (\(_, uri, _) -> uri) attachments
	files = map (\(cid, _, bytes) -> (cid, bytes)) attachments
	attachments = getAttachments attachmentUrl email
	text' = firstOf plainTextBody email
	to' = mapMaybe addressTel $
		recipientHeader "to" email ++ recipientHeader "cc" email
	header h = firstOf (MIME.headers . MIME.header (fromString h)) email

M cheogram-smtp.cabal => cheogram-smtp.cabal +8 -1
@@ 13,6 13,7 @@ common defs
  default-language:    Haskell2010
  ghc-options:         -Wall -Wno-tabs -Wno-orphans -Werror
  build-depends:       base                  >=4.11 && <4.14,
                       aeson                 >= 1.4,
                       attoparsec            >=0.13 && <0.14,
                       basic-prelude         >=0.7 && <0.8,
                       bytestring            >=0.10 && <0.11,


@@ 21,6 22,7 @@ common defs
                       cryptonite            >=0.25 && <0.30,
                       errors                >=2.3 && <2.4,
                       focus                 >= 1.0.1 && < 1.1,
                       http-streams          >= 0.8.0.0 && < 0.9.0.0,
                       ipld-cid              >= 0.1 && < 0.2,
                       lens                  >=4.16 && <4.19,
                       mime-mail             >=0.4 && < 0.5,


@@ 28,7 30,7 @@ common defs
                       network               >= 2.6.3 && < 2.7,
                       network-protocol-xmpp >=0.4 && <0.5,
                       network-uri           >=2.6 && <2.7,
                       purebred-email        >=0.6 && <0.7,
                       purebred-email        >=0.5 && <0.6,
                       stm                   >=2.4 && <2.6,
                       stm-containers        >= 1.1.0 && < 1.2,
                       stm-delay             >=0.1 && <0.2,


@@ 48,6 50,11 @@ executable incoming-email
  main-is:             incoming-email.hs
  other-modules:       Router, Util, Email, IQManager

executable incoming-mms
  import:              defs
  main-is:             incoming-mms.hs
  other-modules:       Util, Email, MMS

test-suite test
  import:              defs
  main-is:             Driver.hs

A incoming-mms.hs => incoming-mms.hs +38 -0
@@ 0,0 1,38 @@
module Main (main) where

import Prelude ()
import BasicPrelude

import qualified Network.Http.Client   as HTTP
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 Email
import MMS
import Util

main :: IO ()
main = do
	(uploadUrl:uploadPath:targetUrl:envelopeTos) <- getArgs
	let cidToPath cid =
		textToString uploadPath ++ "/" ++
		textToString (CID.cidToText cid)

	input <- LByteString.getContents
	let Right email = MIME.parse messageOptionalMboxFrom input

	let (mmss, files) = unzip $ mapMaybe (\envelopeTo ->
			emailToMMS uploadUrl envelopeTo email
		) envelopeTos

	forM_ (concat files) $ \(cid, bytes) ->
		ByteString.writeFile (cidToPath cid) bytes

	forM_ mmss $ \mms ->
		HTTP.post
			(encodeUtf8 targetUrl)
			(s"application/json")
			(HTTP.jsonBody [mms])
			HTTP.simpleHandler'