Commit a4837ae6 authored by Steffen Michels's avatar Steffen Michels

iTasks.Extensions.Email: adapt to changed tcpconnect API, added possibility to...

iTasks.Extensions.Email: adapt to changed tcpconnect API, added possibility to send mails to multiple recipients & add task to send mails with HTML body
parent 61faa281
Pipeline #23541 passed with stage
in 5 minutes and 16 seconds
......@@ -2,6 +2,7 @@ definition module iTasks.Extensions.Email
/**
* This module provides basic SMTP email support
*/
from Text.HTML import :: HtmlTag
import iTasks
/**
......@@ -9,11 +10,22 @@ import iTasks
*
* @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 Recipients: The recipient addresses
* @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 ()
sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
/**
* Send an e-mail message with HTML body.
*
* @param Options: Mail server options, when left blank port 25 on localhost is used SMTP server
* @param Sender: The sender address
* @param Recipients: The recipient addresses
* @param Subject: The subject line of the e-mail message
* @param Body: The HTML body of the e-mail message
*/
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
//Options for sendEmail
:: EmailOpt
......
implementation module iTasks.Extensions.Email
import iTasks
import Text
import Data.Functor
import Text, Text.HTML
sendEmail :: ![EmailOpt] !String !String !String !String -> Task ()
sendEmail opts subject body sender recipient
= tcpconnect server port (constShare ()) {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect,onDestroy= \s->(Ok s, [])}
sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
sendEmail opts sender recipients subject body
= tcpconnect server port (constShare ()) {ConnectionHandlers|onConnect=onConnect,onData=onData,onDisconnect=onDisconnect,onShareChange = \l _ = (Ok l, Nothing, [], False), onDestroy= \s->(Ok s, [])}
@! ()
where
server = getServerOpt opts
......@@ -14,37 +16,43 @@ where
//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)
]
[("",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)
]
//Send the first message
onConnect _ _
onConnect :: !ConnectionId !String !() -> (!MaybeErrorString [(!String, !Int)], !Maybe (), ![String], !Bool)
onConnect _ _ _
= (Ok messages,Nothing,[],False)
//Response to last message: if ok, close connection
whileConnected (Just data) [(_,expectedCode)] _
onData :: !String ![(!String, !Int)] !() -> (!MaybeErrorString [(!String, !Int)], !Maybe (), ![String], !Bool)
onData 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] _
onData 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)
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
sendHtmlEmail opts sender recipients subject body =
sendEmail [EmailOptExtraHeaders [("content-type", "text/html")]: opts] sender recipients subject (toString body)
// SMTP messages
smtpHelo = "HELO localhost\r\n"
smtpFrom email_from = "MAIL FROM:<" +++ (cleanupEmailString email_from) +++ ">\r\n"
......@@ -53,8 +61,9 @@ 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_to -> ("To",cleanupEmailString email_to)) <$> email_to
] ++
[("Subject",cleanupEmailString email_subject)
:email_headers]
]
+++ "\r\n" +++ email_body +++ "\r\n.\r\n"
......@@ -79,5 +88,5 @@ getPortOpt [EmailOptSMTPServerPort s:xs] = s
getPortOpt [x:xs] = getPortOpt xs
getHeadersOpt [] = []
getHeadersOpt [EmailOptExtraHeaders s:xs] = s
getHeadersOpt [EmailOptExtraHeaders s:xs] = s ++ getHeadersOpt xs
getHeadersOpt [x:xs] = getHeadersOpt xs
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