~singpolyma/cheogram-smtp

cheogram-smtp/Email.hs -rw-r--r-- 10.6 KiB
7021b245Stephen Paul Weber jabber:iq:gateway working against my local Gajim 5 months 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
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
module Email where

import Prelude ()
import BasicPrelude
import Data.Char                                 (isAscii, isAlphaNum)
import Data.Functor                              ((<&>), ($>))
import Control.Error
	(headZ, lastZ, justZ, hush, exceptT)
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 qualified Data.ByteString.Char8           as C8
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 qualified Network.Mail.Mime               as Mail
import qualified UnexceptionalIO.Trans           as UIO

import Util

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

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 _)) =
	equalsDecode 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 = encodeUtf8 . fromString . equalsEncode . bareTxt

equalsEncode :: Text -> String
equalsEncode =
	map (\c -> if c == '%' then '=' else c) .
	URI.escapeURIString unescapedInEmailLocalpart .
	textToString

equalsDecode :: ByteString -> Text
equalsDecode =
	fromString . URI.unEscapeString .
	map (\c -> if c == '=' then '%' else c) .
	textToString . decodeUtf8

jidToMailbox :: XMPP.JID -> MIME.Domain -> MIME.Mailbox
jidToMailbox jid domain = MIME.Mailbox (XMPP.strNode <$> XMPP.jidNode 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"id", [XML.ContentText msgid])] []

extractThreadFromRef :: Text -> Atto.Parser Text
extractThreadFromRef domain = mfilter (/= s"\0") $ fmap equalsDecode $
	Atto.satisfy (==0x3C) *>
	Atto.skipWhile (`notElem`[0x2E,0x3E,0x20]) *>
	Atto.satisfy (==0x2E) *>
	Atto.skipWhile (`notElem`[0x2E,0x3E,0x20]) *>
	Atto.satisfy (==0x2E) *>
	Atto.takeTill (`elem`[0x40,0x3E,0x20]) <*
	Atto.satisfy (==0x40) <*
	Atto.string (encodeUtf8 domain) <*
	Atto.satisfy (==0x3E)

extractThreadFromRefs :: Text -> Atto.Parser Text
extractThreadFromRefs domain =
	justZ =<< lastZ =<<
	Atto.sepBy
		((Just <$> extractThreadFromRef domain) <|> skipWord)
		(Atto.many1 $ Atto.satisfy (==0x20))
	where
	skipWord = Atto.skipWhile (/=0x20) $> Nothing

limitReferencesLength :: ByteString -> ByteString
limitReferencesLength refs = C8.unwords $ limit (C8.words refs)
	where
	limit (x:xs) = x : drop (length xs - 4) xs
	limit [] = []

referencesFromInReplyTo :: Text -> MIME.MIMEMessage -> Maybe ByteString
referencesFromInReplyTo domain email =
	maybe replyto (\refs -> fmap ((refs ++ s" ") ++) replyto) extractedRefs
	where
	extractedRefs = fmap encodeUtf8 $ T.stripPrefix (s"References: ") =<<
		(hush . MIME.parse (extractThreadFromRef domain) =<< replyto)
	replyto = firstOf (MIME.headers . MIME.header (s"in-reply-to")) email

emailToThread :: Text -> MIME.MIMEMessage -> Maybe XML.Element
emailToThread domain email = thread <&> \threadID ->
	XML.Element (s"{jabber:component:accept}thread")
	parent
	[XML.NodeContent $ XML.ContentText $ decodeUtf8 threadID]
	where
	parent =
		maybeToList $
		fmap ((,) (s"parent") . (:[]) . XML.ContentText
		)
		(hush . MIME.parse (extractThreadFromRefs domain) =<< refs)
	thread = fmap (s"References: "++) $
		((\x y -> x ++ s" " ++ y) <$> refs <*> msgid) <|> msgid
	msgid = firstOf (MIME.headers . MIME.header (s"message-id")) email
	refs = firstOf (MIME.headers . MIME.header (s"references")) email <|>
		referencesFromInReplyTo domain email

emailSubject :: MIME.MIMEMessage -> Maybe Text
emailSubject email = MIME.decodeEncodedWords MIME.defaultCharsets <$>
		firstOf (MIME.headers . MIME.header (s"subject")) email

chatEmailSubject :: MIME.MIMEMessage -> Maybe Text
chatEmailSubject =
	mfilter (not . (s"Re: Chat: " `T.isPrefixOf`)) .
	mfilter (not . (s"Chat: " `T.isPrefixOf`)) .
	emailSubject

emailToSubject :: XMPP.MessageType -> MIME.MIMEMessage -> Maybe XML.Element
emailToSubject = fmap (mkElement (s"{jabber:component:accept}subject")) .: go
	where
	go XMPP.MessageChat = chatEmailSubject
	go _ = emailSubject

emailToStanza ::
	   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)
	}
	where
	typ = emailToMessageType email
	subject = maybeToList $ emailToSubject typ email
	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 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

mkMessageID :: MIME.Domain -> UTCTime -> XMPP.Message -> ByteString
mkMessageID domain now message = ((s"<" ++) . (++ s">")) $
	MIME.renderAddressSpec $ MIME.AddrSpec
	(fromString $ time ++ "." ++ sid ++ "." ++ thread) domain
	where
	sid = maybe "=00" equalsEncode $ XMPP.stanzaID message
	thread =
		maybe "=00" (equalsEncode . mconcat . XML.elementText) $
		child (s"{jabber:component:accept}thread") message
	time = formatTime defaultTimeLocale "%s" now

mkReferences :: XMPP.Message -> Maybe ByteString
mkReferences =
	fmap (limitReferencesLength . encodeUtf8) .
	(T.stripPrefix (s"References: ") =<<) .
	fmap (mconcat . XML.elementText) .
	child (s"{jabber:component:accept}thread")

data EmailWithEnvelope = EmailWithEnvelope {
	emailMessage :: MIME.MIMEMessage,
	emailEnvelopeFrom :: MIME.AddrSpec,
	emailEnvelopeTo :: MIME.AddrSpec
}

emailMessage' :: Lens' EmailWithEnvelope MIME.MIMEMessage
emailMessage' f (EmailWithEnvelope msg from to) =
	fmap (\msg' -> EmailWithEnvelope msg' from to) (f msg)

sendEmail :: (UIO.Unexceptional m) => String -> EmailWithEnvelope -> m Bool
sendEmail sendmail (EmailWithEnvelope mail from to) =
	exceptT (\(ErrorCall _) -> return False) (const $ return True) $
	UIO.fromIO' (error . show) $ Mail.sendmailCustom sendmail [
		"-i",
		"-f", textToString $ decodeUtf8 $ MIME.renderAddressSpec from,
		"--", textToString $ decodeUtf8 $ MIME.renderAddressSpec to
	] (MIME.renderMessage mail)

messageToEmail ::
	   MIME.Domain
	-> UTCTime
	-> XMPP.Message
	-> Either XMPP.Message EmailWithEnvelope
messageToEmail fromDomain now message@XMPP.Message {
		XMPP.messageFrom = Just from,
		XMPP.messageTo = Just (XMPP.JID (Just toNode) _ _)
	} | Just bodyTxt <- getBody message,
	    Right toMailbox@(MIME.Mailbox _ toAddrSpec) <- parsedToNode =
		Right $ EmailWithEnvelope {
			emailEnvelopeFrom = fromAddrSpec,
			emailEnvelopeTo = toAddrSpec,
			emailMessage =
			set (MIME.headers . at (s"Message-ID")) (Just mid) $
			set (MIME.headers . at (s"References")) refs $
			typeHeaders message $
			set (MIME.headerTo MIME.defaultCharsets)
				[MIME.Single toMailbox] $
			setFrom $
			set (MIME.headers . at (s"Jabber-ID")) jidHeader $
			set (MIME.headers . at (s"Subject")) subjectHeader $
			set MIME.headerDate (Just dateHeader) $
			MIME.createTextPlainMessage bodyTxt
		}
	| Left err <- parsedToNode = Left $
		messageError (
			errorPayload "cancel" "item-not-found"
			(fromString $ "Not a valid email address: " ++ err) []
		)
		message
	where
	mid = mkMessageID fromDomain now message
	refs = mkReferences message
	jidHeader = Just $ MIME.encodeEncodedWords (bareTxt from)
	dateHeader = fromMaybe now $ parseXMPPTime =<<
		XML.attributeText (s"stamp") =<<
		child (s"{urn:xmpp:delay}delay") message
	subjectHeader = MIME.encodeEncodedWords <$>
		(getSubject message <|> defaultSubject message)
	setFrom = set (MIME.headerFrom MIME.defaultCharsets) [fromMailbox]
	fromMailbox@(MIME.Mailbox _ fromAddrSpec) = jidToMailbox from fromDomain
	parsedToNode =
		MIME.parse (MIME.mailbox MIME.defaultCharsets) unescapedToNode
	unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode
messageToEmail _ _ message = Left $
	messageError
	(errorPayload "modify" "bad-request" (s"Could not process message") [])
	message