Update of /project/cl-smtp/cvsroot/cl-smtp In directory clnet:/tmp/cvs-serv3901

Modified Files: CHANGELOG README cl-smtp.asd cl-smtp.lisp Added Files: smtp-output-stream.lisp Log Message: A lot of changes: - add support for sending raw messages - add character quoting in email headers (according to RFC2047) - add condition classes for error reporting - fixed STARTTLS - change authentication functionality See CHANGELOG and source. Thanks Hans Huebner for these changes.

--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2007/11/11 23:10:21 1.10 +++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2008/04/02 18:02:28 1.11 @@ -1,3 +1,13 @@ +Version 20080202.1 +2007.02.02 +Added support for sending raw messages. (Hans Huebner) +Fixed STARTTLS so that an EHLO command is sent after STARTTLS. (Hans Huebner) +Changed Authentication functionality, the actual authentication method used is determined by looking at the advertised features of the SMTP server. (Hans Huebner) +Added non-ASCII character quoting in email headers (according to RFC2047). (Hans Huebner) +Added condition classes for error reporting. (Hans Huebner) +Change cl-smtp.lisp, cl-smtp.asd, CHANGELOG +Add smtp-output-stream.lisp + Version 20071113.1 2007.11.13 Add SSL support, thank Timothy Ritchey for the suggestions. --- /project/cl-smtp/cvsroot/cl-smtp/README 2007/11/11 23:10:21 1.8 +++ /project/cl-smtp/cvsroot/cl-smtp/README 2008/04/02 18:02:28 1.9 @@ -25,26 +25,29 @@ Arguments: - host (String) : hostname or ip-adress of the smtpserver - from (String) : email adress - - to (String or Cons of Strings) : email adress + - to (String or List of Strings) : email adress - subject (String) : subject text - message (String) : message body keywords: - - cc (String or Cons of Strings) : email adress carbon copy - - bcc (String or Cons of Strings): email adress blind carbon copy + - cc (String or List of Strings) : email adress carbon copy + - bcc (String or List of Strings): email adress blind carbon copy - reply-to (String) : email adress - displayname (String) : displayname of the sender - - extra-headers (Cons) : extra headers as alist + - extra-headers (List) : extra headers as alist - html-message (String) : message body formatted with HTML tags - - authentication (Cons) : list with 3 elements - (:method "username" "password") + - authentication (List) : list with 2 or elements + ([:method] "username" "password") method is a keyword :plain or :login + If the method is not specified, the + proper method is determined automatically. - attachments (String or Pathname: attachments to send - Cons of String/Pathnames) + List of String/Pathnames) - buffer-size (Number default 256): controls how much of a attachment file is read on each loop before encoding and transmitting the contents, - the number is interpretted in KB - - ssl (Boolean) : if true than use the STARTTLS functionality to make a ssl connection + the number is interpreted in KB + - ssl (or t :starttls :tls) : if t or :STARTTLS: use the STARTTLS functionality + if :TLS: use TLS directly

Returns nil or error with message

--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2007/11/11 23:10:21 1.12 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/02 18:02:29 1.13 @@ -16,25 +16,18 @@ ;;; File: cl-smtp.asd ;;; Description: cl-smtp ASDF system definition file

-(defpackage :cl-smtp - (:use :cl :asdf) - (:export :send-email)) - -(in-package :cl-smtp) - -(defparameter *debug* nil) - -(defmacro print-debug (str) - `(when *debug* - (print ,str))) - (asdf:defsystem :cl-smtp - :version "20071113.1" - :perform (load-op :after (op webpage) - (pushnew :cl-smtp cl:*features*)) - :depends-on (:usocket #-allegro :cl-base64 - #-allegro :flexi-streams - #-allegro :cl+ssl) - :components ((:file "cl-smtp" :depends-on ("attachments")) - (:file "attachments") - (:file "mime-types"))) + :version "20080202.1" + :perform (load-op :after (op webpage) + (pushnew :cl-smtp cl:*features*)) + :depends-on (:usocket + :trivial-gray-streams + :flexi-streams + #-allegro :cl-base64 + #-allegro :cl+ssl) + :serial t + :components ((:file "package") + (:file "attachments") + (:file "cl-smtp") + (:file "smtp-output-stream") + (:file "mime-types"))) --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2007/11/11 23:10:21 1.11 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2008/04/02 18:02:29 1.12 @@ -34,21 +34,23 @@ (t (error "the "~A" argument is not a string or cons" name))))

+(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *line-with-one-dot* #.(format nil "~C~C.~C~C" #\Return #\NewLine + #\Return #\NewLine)) + (defvar *line-with-two-dots* #.(format nil "~C~C..~C~C" #\Return #\NewLine + #\Return #\NewLine))) + (defun mask-dot (str) - "replace \r\n.\r\n with \r\n..\r\n" - (let ((dotstr (format nil "~C~C.~C~C" #\Return #\NewLine - #\Return #\NewLine)) - (maskdotsr (format nil "~C~C..~C~C" #\Return #\NewLine - #\Return #\NewLine)) - (resultstr "")) + "Replace all occurences of \r\n.\r\n in STR with \r\n..\r\n" + (let ((resultstr "")) (labels ((mask (tempstr) - (let ((n (search dotstr tempstr))) + (let ((n (search *line-with-one-dot* tempstr))) (cond (n (setf resultstr (concatenate 'string resultstr (subseq tempstr 0 n) - maskdotsr)) - (mask (subseq tempstr (+ n 5)))) + *line-with-two-dots*)) + (mask (subseq tempstr (+ n #.(length *line-with-one-dot*))))) (t (setf resultstr (concatenate 'string resultstr tempstr))))))) @@ -60,11 +62,76 @@ #+allegro (excl:string-to-base64-string str) #-allegro (cl-base64:string-to-base64-string str))

+(define-condition smtp-error (error) + ()) + +(define-condition smtp-protocol-error (smtp-error) + ((command :initarg :command :reader command) + (expected-response-code :initarg :expected-response-code :reader expected-response-code) + (response-code :initarg :response-code :reader response-code) + (response-message :initarg :response-message :reader response-message)) + (:report (lambda (condition stream) + (print-unreadable-object (condition stream :type t) + (format stream "a command failed:~%command: ~S expected: ~A response: ~A" + (command condition) + (expected-response-code condition) + (response-message condition)))))) + +(define-condition rcpt-failed (smtp-protocol-error) + ((recipient :initarg :recipient + :reader recipient)) + (:report (lambda (condition stream) + (print-unreadable-object (condition stream :type t) + (format stream "while trying to send email through SMTP, the server rejected the recipient ~A: ~A" + (recipient condition) + (response-message condition)))))) + +(defun smtp-command (stream command expected-response-code + &key (condition-class 'smtp-protocol-error) + condition-arguments) + (when command + (write-to-smtp stream command)) + (multiple-value-bind (code msgstr lines) + (read-from-smtp stream) + (when (/= code expected-response-code) + (apply #'error + condition-class + (append condition-arguments + (list :command command + :expected-response-code expected-response-code + :response-code code + :response-message msgstr)))) + lines)) + +(defun do-with-smtp-mail (host from to thunk &key port authentication ssl local-hostname) + (usocket:with-client-socket (socket stream host port) + (let ((stream (smtp-handshake stream + :authentication authentication + :ssl ssl + :local-hostname local-hostname))) + (initiate-smtp-mail stream from to) + (funcall thunk (make-instance 'smtp-output-stream :encapsulated-stream 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) + &body body) + "Encapsulate a SMTP MAIl conversation. A connection to the SMTP + server on HOST and PORT is established and a MAIL command is + initiated with FROM being the mail sender and TO being the list of + recipients. BODY is evaluated with STREAM-VAR being the stream + connected to the remote SMTP server. BODY is expected to write the + RFC2821 message (headers and body) to STREAM-VAR." + `(do-with-smtp-mail ,host ,from ,to + (lambda (,stream-var) ,@body) + :port ,port + :authentication ,authentication + :ssl ,ssl + :local-hostname ,local-hostname))

(defun send-email (host from to subject message - &key (port 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 - attachments (buffer-size 256) ssl) + attachments (buffer-size 256)) (send-smtp host from (check-arg to "to") subject (mask-dot message) :port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc") :reply-to reply-to @@ -78,186 +145,216 @@ 256) :ssl ssl))

- -(defun send-smtp (host from to subject message - &key (port 25) cc bcc reply-to extra-headers html-message - display-name authentication attachments buffer-size ssl) - (let* ((sock (usocket:socket-stream (usocket:socket-connect host port))) - (boundary (make-random-boundary)) - (html-boundary (if (and attachments html-message) - (make-random-boundary) - boundary))) - (unwind-protect - (let ((stream (open-smtp-connection sock - :authentication authentication - :ssl ssl))) - (send-smtp-headers stream :from from :to to :cc cc :bcc bcc - :reply-to reply-to - :display-name display-name - :extra-headers extra-headers :subject subject) - (when (or attachments html-message) - (send-multipart-headers - stream :attachment-boundary (when attachments boundary) - :html-boundary html-boundary)) - ;;----------- Send the body Message --------------------------- - ;;--- Send the proper headers depending on plain-text, - ;;--- multi-part or html email - (cond ((and attachments html-message) - ;; if both present, start attachment section, - ;; then define alternative section, - ;; then write alternative header - (progn - (generate-message-header - stream :boundary boundary :include-blank-line? nil) - (generate-multipart-header stream html-boundary - :multipart-type "alternative") - (write-blank-line stream) - (generate-message-header - stream :boundary html-boundary :content-type *content-type* - :content-disposition "inline" :include-blank-line? nil))) - (attachments - (generate-message-header - stream :boundary boundary - :content-type *content-type* :content-disposition "inline" - :include-blank-line? nil)) - (html-message - (generate-message-header - stream :boundary html-boundary :content-type *content-type* - :content-disposition "inline")) - (t - (generate-message-header stream :content-type *content-type* - :include-blank-line? nil))) - (write-blank-line stream) - (write-to-smtp stream message) - (write-blank-line stream) - ;;---------- Send Html text if needed ------------------------- - (when html-message - (generate-message-header - stream :boundary html-boundary - :content-type "text/html; charset=ISO-8859-1" - :content-disposition "inline") - (write-to-smtp stream html-message) - (send-end-marker stream html-boundary)) - ;;---------- Send Attachments ----------------------------------- - (when attachments - (dolist (attachment attachments) - (send-attachment stream attachment boundary buffer-size)) - (send-end-marker stream boundary)) - (write-char #. stream) - (write-blank-line stream) - (force-output stream) - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 250) - (error "Message send failed: ~A" msgstr))) - (write-to-smtp stream "QUIT") - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 221) - (error "in QUIT command:: ~A" msgstr)))) - (close sock)))) - -(defun open-smtp-connection (stream &key authentication ssl) - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 220) - (error "wrong response from smtp server: ~A" msgstr))) - (when ssl - (write-to-smtp stream (format nil "EHLO ~A" - (usocket::get-host-name))) - (multiple-value-bind (code msgstr lines) - (read-from-smtp stream) - (when (/= code 250) - (error "wrong response from smtp server: ~A" msgstr)) - (when ssl - (cond - ((find "STARTTLS" lines :test #'equal) - (print-debug "this server supports TLS") - (write-to-smtp stream "STARTTLS") - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 220) - (error "Unable to start TLS: ~A" msgstr)) - (setf stream - #+allegro (socket:make-ssl-client-stream stream) - #-allegro - (let ((s stream)) - (cl+ssl:make-ssl-client-stream - (cl+ssl:stream-fd stream) - :close-callback (lambda () (close s))))) - #-allegro - (setf stream (flexi-streams:make-flexi-stream - stream - :external-format - (flexi-streams:make-external-format - :latin-1 :eol-style :lf))))) - (t - (error "this server does not supports TLS")))))) - (cond - (authentication - (write-to-smtp stream (format nil "EHLO ~A" - (usocket::get-host-name))) - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 250) - (error "wrong response from smtp server: ~A" msgstr))) - (cond - ((eq (car authentication) :plain) - (write-to-smtp stream (format nil "AUTH PLAIN ~A" - (string-to-base64-string - (format nil "~A~C~A~C~A" - (cadr authentication) - #\null (cadr authentication) - #\null - (caddr authentication))))) - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 235) - (error "plain authentication failed: ~A" msgstr)))) - ((eq (car authentication) :login) - (write-to-smtp stream "AUTH LOGIN") - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 334) - (error "login authentication failed: ~A" msgstr))) - (write-to-smtp stream (string-to-base64-string (cadr authentication))) - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 334) - (error "login authentication send username failed: ~A" msgstr))) - (write-to-smtp stream (string-to-base64-string (caddr authentication))) - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 235) - (error "login authentication send password failed: ~A" msgstr)))) - (t - (error "authentication ~A is not supported in cl-smtp" - (car authentication))))) - (t - (write-to-smtp stream (format nil "HELO ~A" (usocket::get-host-name))) - (multiple-value-bind (code msgstr) - (read-from-smtp stream) - (when (/= code 250) - (error "wrong response from smtp server: ~A" msgstr))))) +(defun send-smtp (host from to subject message + &key ssl (port (if (eq :tls ssl) 465 25)) cc bcc + reply-to extra-headers html-message display-name + authentication attachments buffer-size + (local-hostname (usocket::get-host-name))) + (with-smtp-mail (stream host from (append to cc bcc) + :port port + :authentication authentication + :ssl ssl + :local-hostname local-hostname) + (let* ((boundary (make-random-boundary)) + (html-boundary (if (and attachments html-message) + (make-random-boundary) + boundary))) + (send-mail-headers stream + :from from + :to to + :cc cc + :reply-to reply-to + :display-name display-name + :extra-headers extra-headers :subject subject) + (when (or attachments html-message) + (send-multipart-headers stream + :attachment-boundary (when attachments boundary) + :html-boundary html-boundary)) + ;;----------- Send the body Message --------------------------- + ;;--- Send the proper headers depending on plain-text, + ;;--- multi-part or html email + (cond ((and attachments html-message) + ;; if both present, start attachment section, + ;; then define alternative section, + ;; then write alternative header + (progn + (generate-message-header + stream :boundary boundary :include-blank-line? nil) + (generate-multipart-header stream html-boundary + :multipart-type "alternative") + (write-blank-line stream) + (generate-message-header + stream :boundary html-boundary :content-type *content-type* + :content-disposition "inline" :include-blank-line? nil))) + (attachments + (generate-message-header + stream :boundary boundary + :content-type *content-type* :content-disposition "inline" + :include-blank-line? nil)) + (html-message + (generate-message-header + stream :boundary html-boundary :content-type *content-type* + :content-disposition "inline")) + (t + (generate-message-header stream :content-type *content-type* + :include-blank-line? nil))) + (write-blank-line stream) + (write-to-smtp stream message) + (write-blank-line stream) + ;;---------- Send Html text if needed ------------------------- + (when html-message + (generate-message-header + stream :boundary html-boundary + :content-type "text/html; charset=ISO-8859-1" + :content-disposition "inline") + (write-to-smtp stream html-message) + (send-end-marker stream html-boundary)) + ;;---------- Send Attachments ----------------------------------- + (when attachments + (dolist (attachment attachments) + (send-attachment stream attachment boundary buffer-size)) + (send-end-marker stream boundary))))) + +(define-condition no-supported-authentication-method (smtp-error) + ((features :initarg :features :reader features)) + (:report (lambda (condition stream) + (print-unreadable-object (condition stream :type t) + (format stream "SMTP authentication has been requested, but the SMTP server did not advertise any ~ + supported authentication scheme. Features announced: ~{~S~^, ~}" + (features condition)))))) + +(defun smtp-authenticate (stream authentication features) + "Authenticate to the SMTP server connected on STREAM. + AUTHENTICATION is a list of two or three elements. If the first + element is a keyword, it specifies the desired authentication + method (:PLAIN or :LOGIN), which is currently ignored. The actual + method used is determined by looking at the advertised features of + the SMTP server. The (other) two elements of the AUTHENTICATION + list are the login username and password. FEATURES is the list of + features announced by the SMTP server. + + If the server does not announce any compatible authentication scheme, + the NO-SUPPORTED-AUTHENTICATION-METHOD error is signalled." + (when (keywordp (car authentication)) + (pop authentication)) + (let ((server-authentication (loop for i in features + for e = (search "AUTH " i :test #'equal) + when (and e (= e 0)) + return i))) + (destructuring-bind (username password) authentication + (cond + ((search " PLAIN" server-authentication :test #'equal) + (smtp-command stream (format nil "AUTH PLAIN ~A" + (string-to-base64-string + (format nil "~A~C~A~C~A" + username + #\null username + #\null password))) + 235)) + ((search " LOGIN" server-authentication :test #'equal) + (smtp-command stream "AUTH LOGIN" + 334) + (smtp-command stream (string-to-base64-string username) + 334) + (smtp-command stream (string-to-base64-string password) + 235)) + (t + (error 'no-supported-authentication-method :features features)))))) + +(defun smtp-handshake (stream &key authentication ssl local-hostname) + "Perform the initial SMTP handshake on STREAM. Returns the stream + to use further down in the conversation, which may be different from + the original stream if we switched to SSL." +

[150 lines skipped]

--- /project/cl-smtp/cvsroot/cl-smtp/smtp-output-stream.lisp 2008/04/02 18:02:29 NONE +++ /project/cl-smtp/cvsroot/cl-smtp/smtp-output-stream.lisp 2008/04/02 18:02:29 1.1

[237 lines skipped]