Email.icl 3.82 KB
Newer Older
1
implementation module iTasks.Extensions.Email
2

3
import iTasks
4
import Data.Functor, Data.Func
5
import Text, Text.HTML
6

7 8
sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
sendEmail opts sender recipients subject body
9
	= tcpconnect server port timeout (constShare ()) {ConnectionHandlers|onConnect=onConnect,onData=onData,onDisconnect=onDisconnect,onShareChange = \l _ = (Ok l, Nothing, [], False), onDestroy= \s->(Ok s, [])}
10 11 12 13
	@! ()
where
	server 	= getServerOpt opts
	port	= getPortOpt opts
14
	timeout = getTimeoutOpt opts
15 16 17 18 19
	headers = getHeadersOpt opts
	//Sending the message with SMTP is essentially one-way communication
	//but we send it in parts. After each part we get a response with a status code.
	//After each message we check if it is a status code we expect.
	messages =
20 21 22 23 24 25 26 27 28 29 30
			[("",220) //Initially we don't send anything, but wait for the welcome message from the server
			,(smtpHelo, 250)
			,(smtpFrom sender, 250)
			]
		++
			((\recipient -> (smtpTo recipient, 250)) <$> recipients)
		++
			[(smtpData, 354)
			,(smtpBody sender recipients headers subject body, 250)
			,(smtpQuit, 221)
			]
31 32

	//Send the first message
33
	onConnect :: !ConnectionId !String !() -> (!MaybeErrorString [(String, Int)], !Maybe (), ![String], !Bool)
34
    onConnect _ _ _
35 36
        = (Ok messages,Nothing,[],False)
	//Response to last message: if ok, close connection
37
	onData :: !String ![(String, Int)] !() -> (!MaybeErrorString [(String, Int)], !Maybe (), ![String], !Bool)
38
    onData data [(_,expectedCode)] _
39 40 41 42
		| statusCode data == expectedCode
			= (Ok [],Nothing,[],True)
        	= (Error data,Nothing,[],False)
	//Response to other messages: if ok, send next message
43
    onData data [(_,expectedCode):ms] _
44 45 46 47 48 49 50 51 52
		| statusCode data == expectedCode
        	= (Ok ms,Nothing,[fst (hd ms)],False)
        	= (Error data,Nothing,[],False)

	//We don't expect the server to disconnect before we close
	//the connection ourselves
    onDisconnect _ _
		= (Error "SMTP server disconnected unexpectedly",Nothing)

53 54
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
sendHtmlEmail opts sender recipients subject body =
55 56 57 58 59
	sendEmail [EmailOptExtraHeaders [("content-type", "text/html")]: opts] sender recipients subject htmlString
where
	// avoid too long lines (SMTP allows a max length of 1000 characters only)
	// by inserting a newline (\r\n is required for mails) after each tag
	htmlString = replaceSubString ">" ">\r\n" $ toString body
60

61 62 63 64 65 66 67 68
// SMTP messages
smtpHelo = "HELO localhost\r\n"
smtpFrom email_from = "MAIL FROM:<" +++ (cleanupEmailString email_from) +++ ">\r\n"
smtpTo email_to = "RCPT TO:<" +++ (cleanupEmailString email_to) +++ ">\r\n"
smtpData = "DATA\r\n"
smtpBody email_from email_to email_headers email_subject email_body 
	= concat [k+++":"+++ v +++ "\r\n" \\ (k,v) <-
				[("From",cleanupEmailString email_from)
69 70 71
				: (\email_to -> ("To",cleanupEmailString email_to)) <$> email_to
				] ++
				[("Subject",cleanupEmailString email_subject)
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
				:email_headers]
			 ]
	+++ "\r\n" +++ email_body +++ "\r\n.\r\n"
smtpQuit = "QUIT\r\n"

//Utility functions

//Parse the reply of the server into a status code
statusCode :: String -> Int
statusCode msg = toInt (msg % (0,2))

//Strip any newline chars and tabs from a string.
cleanupEmailString :: String -> String
cleanupEmailString s = toString (filter (\x -> not (isMember x ['\r\n\t'])) (fromString s))

getServerOpt [] 						= "localhost"
getServerOpt [EmailOptSMTPServer s:xs]	= s
getServerOpt [x:xs] 					= getServerOpt xs

getPortOpt [] 						= 25 
getPortOpt [EmailOptSMTPServerPort s:xs]	= s
getPortOpt [x:xs] 					= getPortOpt xs

getHeadersOpt [] 							= []
96
getHeadersOpt [EmailOptExtraHeaders s:xs]	= s ++ getHeadersOpt xs
97
getHeadersOpt [x:xs] 						= getHeadersOpt xs
98 99 100 101

getTimeoutOpt []                     = Nothing
getTimeoutOpt [EmailOptTimeout t:xs] = Just t
getTimeoutOpt [x:xs]                 = getTimeoutOpt xs