Commit 898bc776 authored by Jan Idzikowski's avatar Jan Idzikowski
Browse files

Add SSL support, thank Timothy Ritchey for the suggestions.

New boolean keyword argument ssl added to send-email.
parent 66a46fc1
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 Version 20071104.1
2007.11.04 2007.11.04
Fixed bug with the file attachments to solve corrupted files when Fixed bug with the file attachments to solve corrupted files when
...@@ -5,7 +11,7 @@ processed with chunking turned on. (Brian Sorg) ...@@ -5,7 +11,7 @@ processed with chunking turned on. (Brian Sorg)
Added automatically including mime types for attachesments Added automatically including mime types for attachesments
of common known extensions. (Brian Sorg) of common known extensions. (Brian Sorg)
Added Html-messages option to send-mail function. (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 Add mime-type.lisp
Version 20071018.1 Version 20071018.1
......
...@@ -6,6 +6,8 @@ new with support for send attachments, thanks Brian Sorg for the implementation ...@@ -6,6 +6,8 @@ new with support for send attachments, thanks Brian Sorg for the implementation
with authentication support for PLAIN and LOGIN authentication method 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) used cl-base64 and usocket packages (cl-base64 isn't a requirement on ACL)
See INSTALL for prerequisites and build details. See INSTALL for prerequisites and build details.
...@@ -18,7 +20,7 @@ To use cl-smtp: ...@@ -18,7 +20,7 @@ To use cl-smtp:
(cl-smtp:send-email host from to subject message (cl-smtp:send-email host from to subject message
&key (port 25) cc bcc reply-to extra-headers html-message &key (port 25) cc bcc reply-to extra-headers html-message
authentication attachments (buffer-size 256)) authentication attachments (buffer-size 256) ssl)
Arguments: Arguments:
- host (String) : hostname or ip-adress of the smtpserver - host (String) : hostname or ip-adress of the smtpserver
...@@ -42,6 +44,7 @@ To use cl-smtp: ...@@ -42,6 +44,7 @@ To use cl-smtp:
is read on each loop before encoding is read on each loop before encoding
and transmitting the contents, 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 Returns nil or error with message
......
...@@ -29,10 +29,12 @@ ...@@ -29,10 +29,12 @@
(print ,str))) (print ,str)))
(asdf:defsystem :cl-smtp (asdf:defsystem :cl-smtp
:version "20071105.1" :version "20071113.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 #-allegro :cl-base64) :depends-on (:usocket #-allegro :cl-base64
#-allegro :flexi-streams
#-allegro :cl+ssl)
:components ((:file "cl-smtp" :depends-on ("attachments")) :components ((:file "cl-smtp" :depends-on ("attachments"))
(:file "attachments") (:file "attachments")
(:file "mime-types"))) (:file "mime-types")))
...@@ -64,7 +64,7 @@ ...@@ -64,7 +64,7 @@
(defun send-email (host from to subject message (defun send-email (host from to subject message
&key (port 25) cc bcc reply-to extra-headers &key (port 25) cc bcc reply-to extra-headers
html-message display-name authentication html-message display-name authentication
attachments (buffer-size 256)) attachments (buffer-size 256) ssl)
(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
...@@ -75,27 +75,29 @@ ...@@ -75,27 +75,29 @@
:attachments (check-arg attachments "attachments") :attachments (check-arg attachments "attachments")
:buffer-size (if (numberp buffer-size) :buffer-size (if (numberp buffer-size)
buffer-size buffer-size
256))) 256)
:ssl ssl))
(defun send-smtp (host from to subject message (defun send-smtp (host from to subject message
&key (port 25) cc bcc reply-to extra-headers html-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))) (let* ((sock (usocket:socket-stream (usocket:socket-connect host port)))
(boundary (make-random-boundary)) (boundary (make-random-boundary))
(html-boundary (if (and attachments html-message) (html-boundary (if (and attachments html-message)
(make-random-boundary) (make-random-boundary)
boundary))) boundary)))
(unwind-protect (unwind-protect
(progn (let ((stream (open-smtp-connection sock
(open-smtp-connection sock :authentication authentication) :authentication authentication
(send-smtp-headers sock :from from :to to :cc cc :bcc bcc :ssl ssl)))
(send-smtp-headers stream :from from :to to :cc cc :bcc bcc
:reply-to reply-to :reply-to reply-to
:display-name display-name :display-name display-name
:extra-headers extra-headers :subject subject) :extra-headers extra-headers :subject subject)
(when (or attachments html-message) (when (or attachments html-message)
(send-multipart-headers (send-multipart-headers
sock :attachment-boundary (when attachments boundary) stream :attachment-boundary (when attachments boundary)
:html-boundary html-boundary)) :html-boundary html-boundary))
;;----------- Send the body Message --------------------------- ;;----------- Send the body Message ---------------------------
;;--- Send the proper headers depending on plain-text, ;;--- Send the proper headers depending on plain-text,
...@@ -106,175 +108,211 @@ ...@@ -106,175 +108,211 @@
;; then write alternative header ;; then write alternative header
(progn (progn
(generate-message-header (generate-message-header
sock :boundary boundary :include-blank-line? nil) stream :boundary boundary :include-blank-line? nil)
(generate-multipart-header sock html-boundary (generate-multipart-header stream html-boundary
:multipart-type "alternative") :multipart-type "alternative")
(write-blank-line sock) (write-blank-line stream)
(generate-message-header (generate-message-header
sock :boundary html-boundary :content-type *content-type* stream :boundary html-boundary :content-type *content-type*
:content-disposition "inline" :include-blank-line? nil))) :content-disposition "inline" :include-blank-line? nil)))
(attachments (attachments
(generate-message-header (generate-message-header
sock :boundary boundary stream :boundary boundary
:content-type *content-type* :content-disposition "inline" :content-type *content-type* :content-disposition "inline"
:include-blank-line? nil)) :include-blank-line? nil))
(html-message (html-message
(generate-message-header (generate-message-header
sock :boundary html-boundary :content-type *content-type* stream :boundary html-boundary :content-type *content-type*
:content-disposition "inline")) :content-disposition "inline"))
(t (t
(generate-message-header sock :content-type *content-type* (generate-message-header stream :content-type *content-type*
:include-blank-line? nil))) :include-blank-line? nil)))
(write-blank-line sock) (write-blank-line stream)
(write-to-smtp sock message) (write-to-smtp stream message)
(write-blank-line sock) (write-blank-line stream)
;;---------- Send Html text if needed ------------------------- ;;---------- Send Html text if needed -------------------------
(when html-message (when html-message
(generate-message-header (generate-message-header
sock :boundary html-boundary stream :boundary html-boundary
:content-type "text/html; charset=ISO-8859-1" :content-type "text/html; charset=ISO-8859-1"
:content-disposition "inline") :content-disposition "inline")
(write-to-smtp sock html-message) (write-to-smtp stream html-message)
(send-end-marker sock html-boundary)) (send-end-marker stream html-boundary))
;;---------- Send Attachments ----------------------------------- ;;---------- Send Attachments -----------------------------------
(when attachments (when attachments
(dolist (attachment attachments) (dolist (attachment attachments)
(send-attachment sock attachment boundary buffer-size)) (send-attachment stream attachment boundary buffer-size))
(send-end-marker sock boundary)) (send-end-marker stream boundary))
(write-char #\. sock) (write-char #\. stream)
(write-blank-line sock) (write-blank-line stream)
(force-output sock) (force-output stream)
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 250) (when (/= code 250)
(error "Message send failed: ~A" msgstr))) (error "Message send failed: ~A" msgstr)))
(write-to-smtp sock "QUIT") (write-to-smtp stream "QUIT")
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 221) (when (/= code 221)
(error "in QUIT command:: ~A" msgstr)))) (error "in QUIT command:: ~A" msgstr))))
(close sock)))) (close sock))))
(defun open-smtp-connection (sock &key authentication) (defun open-smtp-connection (stream &key authentication ssl)
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 220) (when (/= code 220)
(error "wrong response from smtp server: ~A" msgstr))) (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 (cond
(authentication (authentication
(write-to-smtp sock (format nil "EHLO ~A" (usocket::get-host-name))) (write-to-smtp stream (format nil "EHLO ~A"
(usocket::get-host-name)))
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 250) (when (/= code 250)
(error "wrong response from smtp server: ~A" msgstr))) (error "wrong response from smtp server: ~A" msgstr)))
(cond (cond
((eq (car authentication) :plain) ((eq (car authentication) :plain)
(write-to-smtp sock (format nil "AUTH PLAIN ~A" (write-to-smtp stream (format nil "AUTH PLAIN ~A"
(string-to-base64-string (string-to-base64-string
(format nil "~A~C~A~C~A" (cadr authentication) (format nil "~A~C~A~C~A"
#\null (cadr authentication) #\null (cadr authentication)
#\null (cadr authentication)
#\null
(caddr authentication))))) (caddr authentication)))))
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 235) (when (/= code 235)
(error "plain authentication failed: ~A" msgstr)))) (error "plain authentication failed: ~A" msgstr))))
((eq (car authentication) :login) ((eq (car authentication) :login)
(write-to-smtp sock "AUTH LOGIN") (write-to-smtp stream "AUTH LOGIN")
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 334) (when (/= code 334)
(error "login authentication failed: ~A" msgstr))) (error "login authentication failed: ~A" msgstr)))
(write-to-smtp sock (string-to-base64-string (cadr authentication))) (write-to-smtp stream (string-to-base64-string (cadr authentication)))
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 334) (when (/= code 334)
(error "login authentication send username failed: ~A" msgstr))) (error "login authentication send username failed: ~A" msgstr)))
(write-to-smtp sock (string-to-base64-string (caddr authentication))) (write-to-smtp stream (string-to-base64-string (caddr authentication)))
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 235) (when (/= code 235)
(error "login authentication send password failed: ~A" msgstr)))) (error "login authentication send password failed: ~A" msgstr))))
(t (t
(error "authentication ~A is not supported in cl-smtp" (error "authentication ~A is not supported in cl-smtp"
(car authentication))))) (car authentication)))))
(t (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) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 250) (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 &key from to cc bcc reply-to
extra-headers display-name subject) extra-headers display-name subject)
(write-to-smtp sock (write-to-smtp stream
(format nil "MAIL FROM:~@[~A ~]<~A>" display-name from)) (format nil "MAIL FROM:~@[~A ~]<~A>" display-name from))
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 250) (when (/= code 250)
(error "in MAIL FROM command: ~A" msgstr))) (error "in MAIL FROM command: ~A" msgstr)))
(compute-rcpt-command sock to) (compute-rcpt-command stream to)
(compute-rcpt-command sock cc) (compute-rcpt-command stream cc)
(compute-rcpt-command sock bcc) (compute-rcpt-command stream bcc)
(write-to-smtp sock "DATA") (write-to-smtp stream "DATA")
(multiple-value-bind (code msgstr) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 354) (when (/= code 354)
(error "in DATA command: ~A" msgstr))) (error "in DATA command: ~A" msgstr)))
(write-to-smtp sock (format nil "Date: ~A" (get-email-date-string))) (write-to-smtp stream (format nil "Date: ~A" (get-email-date-string)))
(write-to-smtp sock (format nil "From: ~@[~A <~]~A~@[>~]" (write-to-smtp stream (format nil "From: ~@[~A <~]~A~@[>~]"
display-name from display-name)) display-name from display-name))
(write-to-smtp sock (format nil "To: ~{ ~a~^,~}" to)) (write-to-smtp stream (format nil "To: ~{ ~a~^,~}" to))
(when cc (when cc
(write-to-smtp sock (format nil "Cc: ~{ ~a~^,~}" cc))) (write-to-smtp stream (format nil "Cc: ~{ ~a~^,~}" cc)))
(write-to-smtp sock (format nil "Subject: ~A" subject)) (write-to-smtp stream (format nil "Subject: ~A" subject))
(write-to-smtp sock (format nil "X-Mailer: cl-smtp ~A" (write-to-smtp stream (format nil "X-Mailer: cl-smtp ~A"
*x-mailer*)) *x-mailer*))
(when reply-to (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 (when (and extra-headers
(listp extra-headers)) (listp extra-headers))
(dolist (l extra-headers) (dolist (l extra-headers)
(write-to-smtp sock (write-to-smtp stream
(format nil "~A: ~{~a~^,~}" (car l) (rest l))))) (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 (cond (attachment-boundary
(generate-multipart-header sock attachment-boundary (generate-multipart-header stream attachment-boundary
:multipart-type "mixed")) :multipart-type "mixed"))
(html-boundary (generate-multipart-header (html-boundary (generate-multipart-header
sock html-boundary stream html-boundary
:multipart-type "alternative")) :multipart-type "alternative"))
(t nil))) (t nil)))
(defun compute-rcpt-command (sock adresses) (defun compute-rcpt-command (stream adresses)
(dolist (to 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) (multiple-value-bind (code msgstr)
(read-from-smtp sock) (read-from-smtp stream)
(when (/= code 250) (when (/= code 250)
(error "in RCPT TO command: ~A" msgstr))))) (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)) (print-debug (format nil "to server: ~A" command))
(write-string command sock) (write-string command stream)
(write-char #\Return sock) (write-char #\Return stream)
(write-char #\NewLine sock) (write-char #\NewLine stream)
(force-output sock)) (force-output stream))
(defun write-blank-line (sock) (defun write-blank-line (stream)
(write-char #\Return sock) (write-char #\Return stream)
(write-char #\NewLine sock) (write-char #\NewLine stream)
(force-output sock)) (force-output stream))
(defun read-from-smtp (sock) (defun read-from-smtp (stream &optional lines)
(let* ((line (read-line sock)) (let* ((line (read-line stream))
(response (string-trim '(#\Return #\NewLine) (subseq line 4)))
(response-code (parse-integer line :start 0 :junk-allowed t))) (response-code (parse-integer line :start 0 :junk-allowed t)))
(print-debug (format nil "from server: ~A" line)) (print-debug (format nil "from server: ~A" line))
(if (= (char-code (elt line 3)) (char-code #\-)) (if (= (char-code (elt line 3)) (char-code #\-))
(read-from-smtp sock) (read-from-smtp stream (append lines (list response)))
(values response-code line)))) (values response-code line lines))))
(defun get-email-date-string () (defun get-email-date-string ()
(multiple-value-bind (sec min h d m y wd) (get-decoded-time) (multiple-value-bind (sec min h d m y wd) (get-decoded-time)
......
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