Commit 94e99ed2 authored by Jan Idzikowski's avatar Jan Idzikowski
Browse files

Add keyword envelope-sender to send-email, if envelope-sender not set

then envelope-sender = from argument.
Change x-mailer header setting.

----------------------------------------------------------------------
parent 96d3dafe
Version 20100908.1
2010.09.08
Add keyword envelope-sender to send-email, if envelope-sender not set then
envelope-sender = from argument.
Change x-mailer header setting.
Change cl-smtp.lisp, cl-smtp.asd, CHANGELOG, README
Version 20100621.1 Version 20100621.1
2010.06.21 2010.06.21
Rewrite base64-encode-file in attachments.lisp, fixed wrap at column Rewrite base64-encode-file in attachments.lisp, fixed wrap at column
......
...@@ -49,6 +49,8 @@ Returns nil or error with message ...@@ -49,6 +49,8 @@ Returns nil or error with message
- ssl (or t :starttls :tls) : if t or :STARTTLS: use the STARTTLS functionality - ssl (or t :starttls :tls) : if t or :STARTTLS: use the STARTTLS functionality
if :TLS: use TLS directly if :TLS: use TLS directly
- external-format : symbol, default :utf-8 - external-format : symbol, default :utf-8
- envelope-sender : email adress,
if not set then envelope-sender = from
------------------------------------------------ ------------------------------------------------
......
...@@ -17,7 +17,7 @@ ...@@ -17,7 +17,7 @@
;;; Description: cl-smtp ASDF system definition file ;;; Description: cl-smtp ASDF system definition file
(asdf:defsystem :cl-smtp (asdf:defsystem :cl-smtp
:version "20100621.1" :version "20100908.1"
:perform (load-op :after (op webpage) :perform (load-op :after (op webpage)
(pushnew :cl-smtp cl:*features*)) (pushnew :cl-smtp cl:*features*))
:depends-on (:usocket :depends-on (:usocket
......
...@@ -18,7 +18,7 @@ ...@@ -18,7 +18,7 @@
(in-package :cl-smtp) (in-package :cl-smtp)
(defparameter *x-mailer* (format nil "cl-smtp (~A ~A)" (defparameter *x-mailer* (format nil "(~A ~A)"
(lisp-implementation-type) (lisp-implementation-type)
(lisp-implementation-version))) (lisp-implementation-version)))
...@@ -143,8 +143,7 @@ ...@@ -143,8 +143,7 @@
:response-message msgstr)))) :response-message msgstr))))
lines)) lines))
(defun do-with-smtp-mail (host from to thunk &key port authentication ssl (defun do-with-smtp-mail (host envelope-sender to thunk &key port authentication ssl local-hostname (external-format :utf-8))
local-hostname (external-format :utf-8))
(usocket:with-client-socket (socket stream host port (usocket:with-client-socket (socket stream host port
:element-type '(unsigned-byte 8)) :element-type '(unsigned-byte 8))
(setf stream (flexi-streams:make-flexi-stream (setf stream (flexi-streams:make-flexi-stream
...@@ -156,11 +155,11 @@ ...@@ -156,11 +155,11 @@
:authentication authentication :authentication authentication
:ssl ssl :ssl ssl
:local-hostname local-hostname))) :local-hostname local-hostname)))
(initiate-smtp-mail stream from to) (initiate-smtp-mail stream envelope-sender to)
(funcall thunk stream) (funcall thunk stream)
(finish-smtp-mail stream)))) (finish-smtp-mail stream))))
(defmacro with-smtp-mail ((stream-var host from to &key ssl (port (if (eq :tls ssl) 465 25)) authentication local-hostname (external-format :utf-8)) (defmacro with-smtp-mail ((stream-var host envelope-sender to &key ssl (port (if (eq :tls ssl) 465 25)) authentication local-hostname (external-format :utf-8))
&body body) &body body)
"Encapsulate a SMTP MAIl conversation. A connection to the SMTP "Encapsulate a SMTP MAIl conversation. A connection to the SMTP
server on HOST and PORT is established and a MAIL command is server on HOST and PORT is established and a MAIL command is
...@@ -168,7 +167,7 @@ ...@@ -168,7 +167,7 @@
recipients. BODY is evaluated with STREAM-VAR being the stream recipients. BODY is evaluated with STREAM-VAR being the stream
connected to the remote SMTP server. BODY is expected to write the connected to the remote SMTP server. BODY is expected to write the
RFC2821 message (headers and body) to STREAM-VAR." RFC2821 message (headers and body) to STREAM-VAR."
`(do-with-smtp-mail ,host ,from ,to `(do-with-smtp-mail ,host ,envelope-sender ,to
(lambda (,stream-var) ,@body) (lambda (,stream-var) ,@body)
:port ,port :port ,port
:authentication ,authentication :authentication ,authentication
...@@ -179,7 +178,7 @@ ...@@ -179,7 +178,7 @@
(defun send-email (host from to subject message (defun send-email (host from to subject message
&key ssl (port (if (eq :tls ssl) 465 25)) cc bcc reply-to extra-headers &key ssl (port (if (eq :tls ssl) 465 25)) cc bcc reply-to extra-headers
html-message display-name authentication html-message display-name authentication
attachments (buffer-size 256) (external-format :utf-8)) attachments (buffer-size 256) envelope-sender (external-format :utf-8))
(send-smtp host from (check-arg to "to") subject (mask-dot message) (send-smtp host from (check-arg to "to") subject (mask-dot message)
:port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc") :port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc")
:reply-to reply-to :reply-to reply-to
...@@ -191,6 +190,7 @@ ...@@ -191,6 +190,7 @@
:buffer-size (if (numberp buffer-size) :buffer-size (if (numberp buffer-size)
buffer-size buffer-size
256) 256)
:envelope-sender (or envelope-sender from)
:external-format external-format :external-format external-format
:ssl ssl)) :ssl ssl))
...@@ -199,8 +199,9 @@ ...@@ -199,8 +199,9 @@
reply-to extra-headers html-message display-name reply-to extra-headers html-message display-name
authentication attachments buffer-size authentication attachments buffer-size
(local-hostname (usocket::get-host-name)) (local-hostname (usocket::get-host-name))
(external-format :utf-8)) (envelope-sender from)
(with-smtp-mail (stream host from (append to cc bcc) (external-format :utf-8))
(with-smtp-mail (stream host envelope-sender (append to cc bcc)
:port port :port port
:authentication authentication :authentication authentication
:ssl ssl :ssl ssl
...@@ -380,7 +381,7 @@ ...@@ -380,7 +381,7 @@
(smtp-authenticate stream authentication features))) (smtp-authenticate stream authentication features)))
stream) stream)
(defun initiate-smtp-mail (stream from to) (defun initiate-smtp-mail (stream envelope-sender to)
"Initiate an SMTP MAIL command, sending a MAIL FROM command for the "Initiate an SMTP MAIL command, sending a MAIL FROM command for the
email address in FROM and RCPT commands for all receipients in TO, email address in FROM and RCPT commands for all receipients in TO,
which is expected to be a list. which is expected to be a list.
...@@ -389,7 +390,7 @@ ...@@ -389,7 +390,7 @@
is signalled. This condition may be handled by the caller in order is signalled. This condition may be handled by the caller in order
to send the email anyway." to send the email anyway."
(smtp-command stream (smtp-command stream
(format nil "MAIL FROM:<~A>" (substitute-return-newline from)) (format nil "MAIL FROM:<~A>" (substitute-return-newline envelope-sender))
250) 250)
(dolist (address to) (dolist (address to)
(restart-case (restart-case
...@@ -406,6 +407,7 @@ ...@@ -406,6 +407,7 @@
"Finish sending an email to the SMTP server connected to on STREAM. "Finish sending an email to the SMTP server connected to on STREAM.
The server is expected to be inside of the DATA SMTP command. The The server is expected to be inside of the DATA SMTP command. The
connection is then terminated by sending a QUIT command." connection is then terminated by sending a QUIT command."
;;(fresh-line stream)
(write-to-smtp stream "") (write-to-smtp stream "")
(smtp-command stream "." 250) (smtp-command stream "." 250)
(smtp-command stream "QUIT" 221)) (smtp-command stream "QUIT" 221))
...@@ -430,7 +432,7 @@ ...@@ -430,7 +432,7 @@
(write-to-smtp stream (format nil "Subject: ~A" (write-to-smtp stream (format nil "Subject: ~A"
(rfc2045-q-encode-string (rfc2045-q-encode-string
subject :external-format external-format))) subject :external-format external-format)))
(write-to-smtp stream (format nil "X-Mailer: ~A" (write-to-smtp stream (format nil "X-Mailer: cl-smtp~A"
(rfc2045-q-encode-string (rfc2045-q-encode-string
*x-mailer* :external-format external-format))) *x-mailer* :external-format external-format)))
(when reply-to (when reply-to
......
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