~singpolyma/cheogram-smtp

ref: 3464bcaa8680d0122af20073fbc0072841d8edbd cheogram-smtp/Email.hs -rw-r--r-- 5.9 KiB
3464bcaaStephen Paul Weber Always use line buffering, even when redirected to file 2 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
module Email where

import BasicPrelude
import Prelude ()
import Data.Char                                 (isAscii, isAlphaNum)
import Control.Error                             (headZ, hush)
import Data.Time.Clock                           (UTCTime)
import Control.Lens 
	(Const, Leftmost, filtered, firstOf, view, _Right, set, at)
import qualified Data.Text                       as T
import qualified Data.Attoparsec.ByteString.Lazy as Atto
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

import Util

mboxFrom :: Atto.Parser ()
mboxFrom =
	Atto.string (encodeUtf8 $ s"From ") *>
	Atto.skipWhile (\c -> c /= 0x0D && c /= 0x0A) *>
	MIME.crlf *>
	pure ()

messageID :: Atto.Parser Text
messageID =
	Atto.skipWhile (Atto.inClass " \t\n\r") *>
	Atto.satisfy (==0x3C) *>
	(decodeUtf8 <$> Atto.takeTill (==0x3E)) <* -- @ also required by rfc5332
	Atto.satisfy (==0x3E) <*
	Atto.skipWhile (Atto.inClass " \t\n\r")

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

getEmailBody ::
	   (Text -> Const (Leftmost Text) Text)
	-> MIME.WireEntity
	-> Const (Leftmost Text) MIME.WireEntity
getEmailBody = MIME.transferDecoded' . _Right .
	MIME.charsetPrism MIME.defaultCharsets .
	filtered (not . MIME.isAttachment) .
	MIME.body

plainTextBody ::
	   (Text -> Const (Leftmost Text) Text)
	-> MIME.MIMEMessage
	-> Const (Leftmost Text) MIME.MIMEMessage
plainTextBody = MIME.entities . filtered isTextPlain . getEmailBody

mailboxNode :: MIME.Mailbox -> Text
mailboxNode (MIME.Mailbox _ (MIME.AddrSpec local _)) =
	fromString $ URI.unEscapeString $
	map (\c -> if c == '=' then '%' else c) $
	textToString $ decodeUtf8 local

mailboxToJID :: Text -> MIME.Mailbox -> Maybe XMPP.JID
mailboxToJID domain (MIME.Mailbox _ addrspec) =
	XMPP.parseJID $ escapeJid addr ++ s"@" ++ domain
	where
	addr = decodeUtf8 $ MIME.renderAddressSpec addrspec

-- always escapes . for now
unescapedInEmailLocalpart :: Char -> Bool
unescapedInEmailLocalpart c = isAscii c &&
	(isAlphaNum c || c `elem` "#$&'*+-/?^_`{|}~")

jidToLocalpart :: XMPP.JID -> ByteString
jidToLocalpart jid = encodeUtf8 $ fromString $
	map (\c -> if c == '%' then '=' else c) $
	URI.escapeURIString unescapedInEmailLocalpart bareStr
	where
	bareStr = textToString $ bareTxt jid

jidToMailbox :: XMPP.JID -> MIME.Domain -> MIME.Mailbox
jidToMailbox jid domain = MIME.Mailbox (Just $ bareTxt jid) $
	MIME.AddrSpec (jidToLocalpart jid) domain

emailToMessageType :: MIME.MIMEMessage -> XMPP.MessageType
emailToMessageType email
	| Just _ <- chatVersion email =
		XMPP.MessageChat
	| otherwise = XMPP.MessageNormal
	where
	chatVersion = firstOf (MIME.headers . MIME.header (s"Chat-Version"))

emailToOriginID :: MIME.MIMEMessage -> Maybe XML.Element
emailToOriginID email = fmap originID $ hush . MIME.parse messageID =<<
	firstOf (MIME.headers . MIME.header (s"message-id")) email
	where
	originID msgid = XML.Element (s"{urn:xmpp:sid:0}origin-id")
		[(s"{urn:xmpp:sid:0}id", [XML.ContentText msgid])] []

emailToStanza ::
	   (MIME.Mailbox -> Maybe XMPP.JID)
	-> MIME.MIMEMessage
	-> XMPP.Message
emailToStanza toJid email =
	(XMPP.emptyMessage $ emailToMessageType email) {
		XMPP.messageFrom = toJid fromMailbox,
		XMPP.messagePayloads = [
			XML.Element (s"{jabber:component:accept}subject") []
				[XML.NodeContent $ XML.ContentText subject],
			XML.Element (s"{jabber:component:accept}body") []
				[XML.NodeContent $ XML.ContentText textBody]
		] ++ nick ++ mid
	}
	where
	mid = maybeToList $ emailToOriginID email
	nick = maybeToList $ fmap (\n ->
			XML.Element (s"{http://jabber.org/protocol/nick}nick")
				[] [XML.NodeContent $ XML.ContentText n]
		) fn
	Just textBody = firstOf plainTextBody email
	Just subject = MIME.decodeEncodedWords MIME.defaultCharsets <$>
		firstOf (MIME.headers . MIME.header (s"subject")) email
	Just fromMailbox@(MIME.Mailbox fn _) =
		headZ =<< firstOf (MIME.headerFrom MIME.defaultCharsets) email

defaultSubject :: XMPP.Message -> Maybe Text
defaultSubject message@XMPP.Message { XMPP.messageType = XMPP.MessageChat } =
	(s"Chat: " ++) . T.take 80 <$> getBody message
defaultSubject _ = Nothing

typeHeaders :: XMPP.Message -> MIME.MIMEMessage -> MIME.MIMEMessage
typeHeaders XMPP.Message { XMPP.messageType = XMPP.MessageChat } =
	set (MIME.headers . at (s"Chat-Version")) (Just $ s"1.0")
typeHeaders _ = id

messageToEmail ::
	   MIME.Domain
	-> UTCTime
	-> XMPP.Message
	-> Maybe (MIME.Mailbox, MIME.MIMEMessage)
messageToEmail fromDomain now message@XMPP.Message {
		XMPP.messageFrom = Just from,
		XMPP.messageTo = Just (XMPP.JID (Just toNode) _ _)
	} | Just bodyTxt <- getBody message,
	    Right toAddress <- parsedToNode =
		Just (fromMailbox,
			typeHeaders message $
			set (MIME.headerTo MIME.defaultCharsets) [toAddress] $
			setFrom $
			set (MIME.headers . at (s"Jabber-ID")) jidHeader $
			set (MIME.headers . at (s"Subject")) subjectHeader $
			set MIME.headerDate (Just dateHeader) $
			MIME.createTextPlainMessage bodyTxt
		)
	where
	jidHeader = Just $ MIME.encodeEncodedWords (bareTxt from)
	dateHeader = fromMaybe now $ parseXMPPTime =<<
		XML.attributeText (s"{urn:xmpp:delay}stamp") =<<
		child (s"{urn:xmpp:delay}delay") message
	subjectHeader = MIME.encodeEncodedWords <$>
		(getSubject message <|> defaultSubject message)
	setFrom = set (MIME.headerFrom MIME.defaultCharsets) [fromMailbox]
	fromMailbox = jidToMailbox from fromDomain
	parsedToNode =
		MIME.parse (MIME.address MIME.defaultCharsets) unescapedToNode
	unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode
messageToEmail _ _ _ = Nothing