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 =