Commit 3f633f46 authored by Bas Lijnse's avatar Bas Lijnse

Replaced blocking email task with asynchronous pure itasks version

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@3943 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent a5432d02
......@@ -72,21 +72,3 @@ callRPCHTTP :: !HTTPMethod !URI ![(String,String)] !(HTTPResponse -> a) -> Task
*/
withTemporaryDirectory :: (FilePath -> Task a) -> Task a | iTask a
/**
* Send an e-mail message.
*
* @param Subject: The subject line of the e-mail
* @param Body: The body of the e-mail
* @param Sender: The sender address
* @param Recipients: The list of recipients
*
* @return The recipients to which the email was sent
* @gin-title Send e-mail
* @gin-icon email
*/
sendEmail :: !String !Note !sndr ![rcpt] -> Task [EmailAddress] | toEmail sndr & toEmail rcpt
class toEmail r where toEmail :: !r -> EmailAddress
instance toEmail EmailAddress
instance toEmail String
......@@ -18,8 +18,6 @@ from System.File import qualified fileExists, readFile
from Data.Map import qualified newMap, put
from System.Process import qualified ::ProcessHandle, runProcess, checkProcess,callProcess
from System.Process import :: ProcessHandle(..)
from Email import qualified sendEmail
from Email import :: Email(..), :: EmailOption(..)
from StdFunc import o
derive JSONEncode ProcessHandle
......@@ -258,23 +256,3 @@ where
eval _ _ _ iworld
= (ExceptionResult (exception "Corrupt task state in withShared"), iworld)
sendEmail :: !String !Note !sndr ![rcpt] -> Task [EmailAddress] | toEmail sndr & toEmail rcpt
sendEmail subject (Note body) sender recipients = mkInstantTask eval
where
eval taskId iworld=:{IWorld|current={taskTime},config}
# sender = toEmail sender
# recipients = map toEmail recipients
# iworld = foldr (sendSingle config.smtpServer sender) iworld recipients
= (Ok recipients, iworld)
sendSingle server (EmailAddress sender) (EmailAddress address) iworld=:{IWorld|world}
# (_,world) = 'Email'.sendEmail [EmailOptSMTPServer server]
{email_from = sender
,email_to = address
,email_subject = subject
,email_body = body
} world
= {IWorld|iworld & world = world}
instance toEmail EmailAddress where toEmail e = e
instance toEmail String where toEmail s = EmailAddress s
definition module iTasks.API.Extensions.Email
/**
* This module provides basic SMTP email support
*/
import iTasks
/**
* Send an e-mail message.
*
* @param Options: Mail server options, when left blank port 25 on localhost is used SMTP server
* @param Sender: The sender address
* @param Recipient: The recipient address
* @param Subject: The subject line of the e-mail message
* @param Body: The body of the e-mail message
*/
sendEmail :: ![EmailOpt] !String !String !String !String -> Task ()
//Options for sendEmail
:: EmailOpt
= EmailOptSMTPServer !String //SMTP server to use. Default: localhost
| EmailOptSMTPServerPort !Int //TCP port of the SMTP server to use. Default: 25
| EmailOptExtraHeaders ![(!String,!String)] //Additional headers to add before the body
implementation module iTasks.API.Extensions.Email
import iTasks
import Text
sendEmail :: ![EmailOpt] !String !String !String !String -> Task ()
sendEmail opts subject body sender recipient
= tcpconnect server port (constShare ()) {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect}
@! ()
where
server = getServerOpt opts
port = getPortOpt opts
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 =
[("",220) //Initially we don't send anything, but wait for the welcome message from the server
,(smtpHelo, 250)
,(smtpFrom sender, 250)
,(smtpTo recipient, 250)
,(smtpData, 354)
,(smtpBody sender recipient headers subject body, 250)
,(smtpQuit, 221)
]
//Send the first message
onConnect _ _
= (Ok messages,Nothing,[],False)
//Response to last message: if ok, close connection
whileConnected (Just data) [(_,expectedCode)] _
| statusCode data == expectedCode
= (Ok [],Nothing,[],True)
= (Error data,Nothing,[],False)
//Response to other messages: if ok, send next message
whileConnected (Just data) [(_,expectedCode):ms] _
| statusCode data == expectedCode
= (Ok ms,Nothing,[fst (hd ms)],False)
= (Error data,Nothing,[],False)
//All other cases: just wait
whileConnected _ state _
= (Ok state,Nothing,[],False)
//We don't expect the server to disconnect before we close
//the connection ourselves
onDisconnect _ _
= (Error "SMTP server disconnected unexpectedly",Nothing)
// 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)
,("To",cleanupEmailString email_to)
,("Subject",cleanupEmailString email_subject)
: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 [] = []
getHeadersOpt [EmailOptExtraHeaders s:xs] = s
getHeadersOpt [x:xs] = getHeadersOpt xs
definition module Email
// This library sends emails from Clean using SMTP.
// Simple e-mail message, this type of message is the
// bare mimimum to send an e-mail.
:: Email = { email_from :: String
, email_to :: String
, email_subject :: String
, email_body :: String
}
// For more advanced e-mail messages, there should be a
// MimeEmail type which can do cc,bcc,html-mail, attachments etc.
:: EmailOption = EmailOptSMTPServer String
// Send function which sends the e-mail out
sendEmail :: [EmailOption] Email *World -> (Bool,*World)
\ No newline at end of file
implementation module Email
import TCPChannels
import StdMaybe
import StdTuple, StdInt, StdList
// Send function which sends the e-mail out
sendEmail :: [EmailOption] Email *World -> (Bool,*World)
sendEmail options email world
// Lookup ip address of SMTP server
# (mbIp, world) = lookupIPAddress (getSMTPServerOpt options) world
| isNothing mbIp = (False,world)
// Connect to the SMTP server
# (tReport, mbDuplex, world) = connectTCP_MT Nothing ((fromJust mbIp),25) world
| tReport <> TR_Success = (False,world)
# {sChannel, rChannel} = fromJust mbDuplex
// Read welcome message
# (msg, rChannel, world) = receive rChannel world
| statusCode msg <> 220 = (False,world)
// Send HELO command
# (sChannel, world) = send (toByteSeq mkSMTPHelo) sChannel world
# (msg, rChannel, world) = receive rChannel world
// Send FROM command
# (sChannel, world) = send (toByteSeq (mkSMTPFrom email)) sChannel world
# (msg, rChannel, world) = receive rChannel world
| statusCode msg <> 250 = (False,world)
// Send TO command
# (sChannel, world) = send (toByteSeq (mkSMTPTo email)) sChannel world
# (msg, rChannel, world) = receive rChannel world
| statusCode msg <> 250 = (False,world)
// Send DATA command
# (sChannel, world) = send (toByteSeq mkSMTPData) sChannel world
# (msg, rChannel, world) = receive rChannel world
| statusCode msg <> 354 = (False,world)
// Send body
# (sChannel, world) = send (toByteSeq (mkSMTPBody email)) sChannel world
# (msg, rChannel, world) = receive rChannel world
| statusCode msg <> 250 = (False,world)
// Send QUIT command
# (sChannel, world) = send (toByteSeq mkSMTPQuit) sChannel world
# (msg, rChannel, world) = receive rChannel world //Ignore this reply, we are done anyway
// Disconnect (the server should have already done this)
# world = closeChannel sChannel world
# world = closeRChannel rChannel world
= (True,world)
// SMTP Protocol handling functions
// Make the SMTP Helo command
mkSMTPHelo :: String
mkSMTPHelo = "HELO localhost\r\n"
// Make the SMTP From command
mkSMTPFrom :: Email -> String
mkSMTPFrom email = "MAIL FROM:<" +++ (cleanupEmailString email.email_from) +++ ">\r\n"
// Make the SMTP To command
mkSMTPTo :: Email -> String
mkSMTPTo email = "RCPT TO:<" +++ (cleanupEmailString email.email_to) +++ ">\r\n"
// Make the SMTP Data command
mkSMTPData :: String
mkSMTPData = "DATA\r\n"
// Make the SMTP message body that is sent after the message
mkSMTPBody :: Email -> String
mkSMTPBody email = "From: " +++ (cleanupEmailString email.email_from) +++ "\r\n"
+++ "To: " +++ (cleanupEmailString email.email_to) +++ "\r\n"
+++ "Subject: " +++ (cleanupEmailString email.email_subject) +++ "\r\n"
+++ "\r\n" +++ email.email_body +++ "\r\n.\r\n"
mkSMTPQuit :: String
mkSMTPQuit = "QUIT\r\n"
//Utility functions
getSMTPServerOpt :: [EmailOption] -> String
getSMTPServerOpt [] = "localhost" //Default is localhost
getSMTPServerOpt [EmailOptSMTPServer s:xs] = s
getSMTPServerOpt [x:xs] = getSMTPServerOpt xs
//Parse the reply of the server into a status code
statusCode :: ByteSeq -> Int
statusCode msg = toInt ((toString 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))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment