Merge branch 'emailAttachments' into 'master'

make to possible to add attachments to emails

See merge request !361

Libraries/iTasks/Extensions/Email.dcl

@@ -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.
+	}

Libraries/iTasks/Extensions/Email.icl

 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