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

Modified Files: CHANGELOG README cl-smtp.asd cl-smtp.lisp Log Message: Add SSL support, thank Timothy Ritchey for the suggestions. New boolean keyword argument ssl added to send-email.

--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2007/11/03 23:53:29 1.9 +++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2007/11/11 23:10:21 1.10 @@ -1,3 +1,9 @@ +Version 20071113.1 +2007.11.13 +Add SSL support, thank Timothy Ritchey for the suggestions. +New boolean keyword argument ssl added to send-email. +Change cl-smtp.lisp, cl-smtp.asd, README, CHANGELOG + Version 20071104.1 2007.11.04 Fixed bug with the file attachments to solve corrupted files when @@ -5,7 +11,7 @@ Added automatically including mime types for attachesments of common known extensions. (Brian Sorg) Added Html-messages option to send-mail function. (Brian Sorg) -Change attachments.lisp, cl-smtp.asd, cl-smtp.lisp, README, CHANGLOG +Change attachments.lisp, cl-smtp.asd, cl-smtp.lisp, README, CHANGELOG Add mime-type.lisp

Version 20071018.1 --- /project/cl-smtp/cvsroot/cl-smtp/README 2007/11/03 23:53:29 1.7 +++ /project/cl-smtp/cvsroot/cl-smtp/README 2007/11/11 23:10:21 1.8 @@ -6,6 +6,8 @@

with authentication support for PLAIN and LOGIN authentication method

+and ssl support with cl+ssl package + used cl-base64 and usocket packages (cl-base64 isn't a requirement on ACL)

See INSTALL for prerequisites and build details. @@ -18,7 +20,7 @@

(cl-smtp:send-email host from to subject message &key (port 25) cc bcc reply-to extra-headers html-message - authentication attachments (buffer-size 256)) + authentication attachments (buffer-size 256) ssl)

Arguments: - host (String) : hostname or ip-adress of the smtpserver @@ -41,7 +43,8 @@ - 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 + the number is interpretted in KB + - ssl (Boolean) : if true than use the STARTTLS functionality to make a ssl connection

Returns nil or error with message

--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2007/11/05 19:58:24 1.11 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2007/11/11 23:10:21 1.12 @@ -29,10 +29,12 @@ (print ,str)))

(asdf:defsystem :cl-smtp - :version "20071105.1" + :version "20071113.1" :perform (load-op :after (op webpage) (pushnew :cl-smtp cl:*features*)) - :depends-on (:usocket #-allegro :cl-base64) + :depends-on (:usocket #-allegro :cl-base64 + #-allegro :flexi-streams + #-allegro :cl+ssl) :components ((:file "cl-smtp" :depends-on ("attachments")) (:file "attachments") (:file "mime-types"))) --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2007/11/05 19:58:24 1.10 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2007/11/11 23:10:21 1.11 @@ -63,8 +63,8 @@

(defun send-email (host from to subject message &key (port 25) cc bcc reply-to extra-headers - html-message display-name authentication - attachments (buffer-size 256)) + html-message display-name authentication + attachments (buffer-size 256) ssl) (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 @@ -75,206 +75,244 @@ :attachments (check-arg attachments "attachments") :buffer-size (if (numberp buffer-size) buffer-size - 256))) + 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) + 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 - (progn - (open-smtp-connection sock :authentication authentication) - (send-smtp-headers sock :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 - sock :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 - sock :boundary boundary :include-blank-line? nil) - (generate-multipart-header sock html-boundary - :multipart-type "alternative") - (write-blank-line sock) - (generate-message-header - sock :boundary html-boundary :content-type *content-type* - :content-disposition "inline" :include-blank-line? nil))) - (attachments - (generate-message-header - sock :boundary boundary - :content-type *content-type* :content-disposition "inline" - :include-blank-line? nil)) - (html-message - (generate-message-header - sock :boundary html-boundary :content-type *content-type* - :content-disposition "inline")) - (t - (generate-message-header sock :content-type *content-type* - :include-blank-line? nil))) - (write-blank-line sock) - (write-to-smtp sock message) - (write-blank-line sock) - ;;---------- Send Html text if needed ------------------------- - (when html-message - (generate-message-header - sock :boundary html-boundary - :content-type "text/html; charset=ISO-8859-1" - :content-disposition "inline") - (write-to-smtp sock html-message) - (send-end-marker sock html-boundary)) - ;;---------- Send Attachments ----------------------------------- - (when attachments - (dolist (attachment attachments) - (send-attachment sock attachment boundary buffer-size)) - (send-end-marker sock boundary)) - (write-char #. sock) - (write-blank-line sock) - (force-output sock) - (multiple-value-bind (code msgstr) - (read-from-smtp sock) - (when (/= code 250) - (error "Message send failed: ~A" msgstr))) - (write-to-smtp sock "QUIT") - (multiple-value-bind (code msgstr) - (read-from-smtp sock) - (when (/= code 221) - (error "in QUIT command:: ~A" msgstr)))) + (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 (sock &key authentication) +(defun open-smtp-connection (stream &key authentication ssl) (multiple-value-bind (code msgstr) - (read-from-smtp sock) + (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 sock (format nil "EHLO ~A" (usocket::get-host-name))) - (multiple-value-bind (code msgstr) - (read-from-smtp sock) + (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 sock (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 sock) - (when (/= code 235) - (error "plain authentication failed: ~A" msgstr)))) - ((eq (car authentication) :login) - (write-to-smtp sock "AUTH LOGIN") - (multiple-value-bind (code msgstr) - (read-from-smtp sock) - (when (/= code 334) - (error "login authentication failed: ~A" msgstr))) - (write-to-smtp sock (string-to-base64-string (cadr authentication))) - (multiple-value-bind (code msgstr) - (read-from-smtp sock) - (when (/= code 334) - (error "login authentication send username failed: ~A" msgstr))) - (write-to-smtp sock (string-to-base64-string (caddr authentication))) - (multiple-value-bind (code msgstr) - (read-from-smtp sock) - (when (/= code 235) - (error "login authentication send password failed: ~A" msgstr)))) - (t - (error "authentication ~A is not supported in cl-smtp" - (car authentication))))) + (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 sock (format nil "HELO ~A" (usocket::get-host-name))) + (write-to-smtp stream (format nil "HELO ~A" (usocket::get-host-name))) (multiple-value-bind (code msgstr) - (read-from-smtp sock) + (read-from-smtp stream) (when (/= code 250) - (error "wrong response from smtp server: ~A" msgstr)))))) + (error "wrong response from smtp server: ~A" msgstr))))) + stream)

-(defun send-smtp-headers (sock +(defun send-smtp-headers (stream &key from to cc bcc reply-to extra-headers display-name subject) - (write-to-smtp sock + (write-to-smtp stream (format nil "MAIL FROM:~@[~A ~]<~A>" display-name from)) (multiple-value-bind (code msgstr) - (read-from-smtp sock) + (read-from-smtp stream) (when (/= code 250) (error "in MAIL FROM command: ~A" msgstr))) - (compute-rcpt-command sock to) - (compute-rcpt-command sock cc) - (compute-rcpt-command sock bcc) - (write-to-smtp sock "DATA") + (compute-rcpt-command stream to) + (compute-rcpt-command stream cc) + (compute-rcpt-command stream bcc) + (write-to-smtp stream "DATA") (multiple-value-bind (code msgstr) - (read-from-smtp sock) + (read-from-smtp stream) (when (/= code 354) (error "in DATA command: ~A" msgstr))) - (write-to-smtp sock (format nil "Date: ~A" (get-email-date-string))) - (write-to-smtp sock (format nil "From: ~@[~A <~]~A~@[>~]" - display-name from display-name)) - (write-to-smtp sock (format nil "To: ~{ ~a~^,~}" to)) + (write-to-smtp stream (format nil "Date: ~A" (get-email-date-string))) + (write-to-smtp stream (format nil "From: ~@[~A <~]~A~@[>~]" + display-name from display-name)) + (write-to-smtp stream (format nil "To: ~{ ~a~^,~}" to)) (when cc - (write-to-smtp sock (format nil "Cc: ~{ ~a~^,~}" cc))) - (write-to-smtp sock (format nil "Subject: ~A" subject)) - (write-to-smtp sock (format nil "X-Mailer: cl-smtp ~A" - *x-mailer*)) + (write-to-smtp stream (format nil "Cc: ~{ ~a~^,~}" cc))) + (write-to-smtp stream (format nil "Subject: ~A" subject)) + (write-to-smtp stream (format nil "X-Mailer: cl-smtp ~A" + *x-mailer*)) (when reply-to - (write-to-smtp sock (format nil "Reply-To: ~A" reply-to))) + (write-to-smtp stream (format nil "Reply-To: ~A" reply-to))) (when (and extra-headers (listp extra-headers)) (dolist (l extra-headers) - (write-to-smtp sock + (write-to-smtp stream (format nil "~A: ~{~a~^,~}" (car l) (rest l))))) - (write-to-smtp sock "Mime-Version: 1.0")) + (write-to-smtp stream "Mime-Version: 1.0"))

-(defun send-multipart-headers (sock &key attachment-boundary html-boundary) +(defun send-multipart-headers (stream &key attachment-boundary html-boundary) (cond (attachment-boundary - (generate-multipart-header sock attachment-boundary + (generate-multipart-header stream attachment-boundary :multipart-type "mixed")) (html-boundary (generate-multipart-header - sock html-boundary + stream html-boundary :multipart-type "alternative")) (t nil)))

-(defun compute-rcpt-command (sock adresses) +(defun compute-rcpt-command (stream adresses) (dolist (to adresses) - (write-to-smtp sock (format nil "RCPT TO:<~A>" to)) + (write-to-smtp stream (format nil "RCPT TO:<~A>" to)) (multiple-value-bind (code msgstr) - (read-from-smtp sock) + (read-from-smtp stream) (when (/= code 250) (error "in RCPT TO command: ~A" msgstr)))))

-(defun write-to-smtp (sock command) +(defun write-to-smtp (stream command) (print-debug (format nil "to server: ~A" command)) - (write-string command sock) - (write-char #\Return sock) - (write-char #\NewLine sock) - (force-output sock)) - -(defun write-blank-line (sock) - (write-char #\Return sock) - (write-char #\NewLine sock) - (force-output sock)) - -(defun read-from-smtp (sock) - (let* ((line (read-line sock)) + (write-string command stream) + (write-char #\Return stream) + (write-char #\NewLine stream) + (force-output stream)) + +(defun write-blank-line (stream) + (write-char #\Return stream) + (write-char #\NewLine stream) + (force-output stream)) + +(defun read-from-smtp (stream &optional lines) + (let* ((line (read-line stream)) + (response (string-trim '(#\Return #\NewLine) (subseq line 4))) (response-code (parse-integer line :start 0 :junk-allowed t))) (print-debug (format nil "from server: ~A" line)) (if (= (char-code (elt line 3)) (char-code #-)) - (read-from-smtp sock) - (values response-code line))))

[5 lines skipped]