Commit ddd8e2de authored by Camil Staps's avatar Camil Staps 🍃

Merge branch 'emailAttachments' into 'master'

make to possible to add attachments to emails

See merge request !361
parents 62fabb05 36bcb476
Pipeline #33955 passed with stage
in 6 minutes and 57 seconds
......@@ -14,8 +14,9 @@ import iTasks
* @param Recipients: The recipient addresses
* @param Subject: The subject line of the e-mail message
* @param Body: The body of the e-mail message
* @param Attachments: Attachments added to the e-mail message
*/
sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
sendEmail :: ![EmailOpt] !String ![String] !String !String ![Attachment] -> Task ()
/**
* Send an e-mail message with HTML body.
......@@ -25,8 +26,9 @@ sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
* @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. Text has to be UTF-8 encoded.
* @param Attachments: Attachments added to the e-mail message.
*/
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag ![Attachment] -> Task ()
//Options for sendEmail
:: EmailOpt
......@@ -34,3 +36,9 @@ sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
| EmailOptSMTPServerPort !Int //TCP port of the SMTP server to use. Default: 25
| EmailOptExtraHeaders ![(String,String)] //Additional headers to add before the body
| EmailOptTimeout !Timeout // TCP timeout
//* Email attachment.
:: Attachment =
{ name :: !String //* The attachment's filename.
, content :: !{#Char} //* Content of the attachment, arbitrary binary data.
}
implementation module iTasks.Extensions.Email
import iTasks
import StdEnv
import Data.Functor, Data.Func
import Text, Text.HTML
import Text, Text.HTML, Text.Encodings.Base64
import iTasks
sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
sendEmail opts sender recipients subject body
sendEmail :: ![EmailOpt] !String ![String] !String !String ![Attachment] -> Task ()
sendEmail opts sender recipients subject body attachments
= tcpconnect server port timeout (constShare ()) {ConnectionHandlers|onConnect=onConnect,onData=onData,onDisconnect=onDisconnect,onShareChange = \l _ = (Ok l, Nothing, [], False), onDestroy= \s->(Ok s, [])}
@! ()
where
......@@ -25,7 +26,7 @@ where
((\recipient -> (smtpTo recipient, 250)) <$> recipients)
++
[(smtpData, 354)
,(smtpBody sender recipients headers subject body, 250)
,(smtpBody sender recipients headers subject body attachments, 250)
,(smtpQuit, 221)
]
......@@ -50,10 +51,15 @@ where
onDisconnect _ _
= (Error "SMTP server disconnected unexpectedly",Nothing)
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
sendHtmlEmail opts sender recipients subject body =
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag ![Attachment] -> Task ()
sendHtmlEmail opts sender recipients subject body attachments =
sendEmail
[EmailOptExtraHeaders [("content-type", "text/html; charset=UTF8")]: opts] sender recipients subject htmlString
[EmailOptExtraHeaders [("content-type", "text/html; charset=UTF8")]: opts]
sender
recipients
subject
htmlString
attachments
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
......@@ -64,15 +70,36 @@ 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)
: (\email_to -> ("To",cleanupEmailString email_to)) <$> email_to
] ++
[("Subject",cleanupEmailString email_subject)
:email_headers]
]
+++ "\r\n" +++ email_body +++ "\r\n.\r\n"
smtpBody email_from email_to bodyHeaders email_subject email_body attachments =
concat $ flatten $
[ [k, ":", v, "\r\n"]
\\ (k, v) <-
[ ("From", cleanupEmailString email_from)
: (\email_to -> ("To", cleanupEmailString email_to)) <$> email_to
]
++
[("Subject", cleanupEmailString email_subject)]
]
++
if (isEmpty attachments) [] [["Content-Type: multipart/mixed; boundary=sep\r\n--sep\r\n"]]
++
[[k, ":", v, "\r\n"] \\ (k, v) <- bodyHeaders]
++
[["\r\n", email_body, "\r\n"], if (isEmpty attachments) [] ["--sep"], ["\r\n"]]
++
[ flatten $
[ [ "content-type: application/octet-stream; name=\"", attachment.Attachment.name, "\"\r\n"
, "content-disposition: attachment; filename=\"", attachment.Attachment.name, "\"\r\n"
, "content-transfer-encoding: base64\r\n"
, "\r\n"
]
, withRestrictedLineLength (base64Encode attachment.content)
, ["\r\n--sep\r\n"]
]
\\ attachment <- attachments
]
++
[[".\r\n"]]
smtpQuit = "QUIT\r\n"
//Utility functions
......@@ -100,3 +127,13 @@ getHeadersOpt [x:xs] = getHeadersOpt xs
getTimeoutOpt [] = Nothing
getTimeoutOpt [EmailOptTimeout t:xs] = Just t
getTimeoutOpt [x:xs] = getTimeoutOpt xs
//* Cut into lines of 1000 character (including "\r\n"), to fulfil SMTP standard.
withRestrictedLineLength :: !String -> [String]
withRestrictedLineLength str = reverse $ withRestrictedLineLength` 0 []
where
withRestrictedLineLength` i acc
| strSize - i <= 998 = [str % (i, strSize - 1): acc]
| otherwise = withRestrictedLineLength` (i + 998) ["\r\n", str % (i, i + 997): acc]
strSize = size str
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