3 files changed, 137 insertions(+), 1 deletions(-)

A MMS.hs
M cheogram-smtp.cabal
A incoming-mms.hs

@@ 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

@@ 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

@@ 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'