[cl-smtp-cvs] CVS cl-smtp
jidzikowski
jidzikowski at common-lisp.net
Sun Nov 11 23:10:21 UTC 2007
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]
More information about the Cl-smtp-cvs
mailing list