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
...@@ -41,7 +43,8 @@ To use cl-smtp: ...@@ -41,7 +43,8 @@ To use cl-smtp:
- buffer-size (Number default 256): controls how much of a attachment file - buffer-size (Number default 256): controls how much of a attachment file
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")))
...@@ -63,8 +63,8 @@ ...@@ -63,8 +63,8 @@
(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,206 +75,244 @@ ...@@ -75,206 +75,244 @@
: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)))
:reply-to reply-to (send-smtp-headers stream :from from :to to :cc cc :bcc bcc
:display-name display-name :reply-to reply-to
:extra-headers extra-headers :subject subject) :display-name display-name
(when (or attachments html-message) :extra-headers extra-headers :subject subject)
(send-multipart-headers (when (or attachments html-message)
sock :attachment-boundary (when attachments boundary) (send-multipart-headers
:html-boundary html-boundary)) stream :attachment-boundary (when attachments boundary)
;;----------- Send the body Message --------------------------- :html-boundary html-boundary))
;;--- Send the proper headers depending on plain-text, ;;----------- Send the body Message ---------------------------
;;--- multi-part or html email ;;--- Send the proper headers depending on plain-text,
(cond ((and attachments html-message) ;;--- multi-part or html email
;; if both present, start attachment section, (cond ((and attachments html-message)
;; then define alternative section, ;; if both present, start attachment section,
;; then write alternative header ;; then define alternative section,
(progn ;; then write alternative header
(generate-message-header (progn
sock :boundary boundary :include-blank-line? nil) (generate-message-header
(generate-multipart-header sock html-boundary stream :boundary boundary :include-blank-line? nil)
:multipart-type "alternative") (generate-multipart-header stream html-boundary
(write-blank-line sock) :multipart-type "alternative")
(generate-message-header (write-blank-line stream)
sock :boundary html-boundary :content-type *content-type* (generate-message-header
:content-disposition "inline" :include-blank-line? nil))) stream :boundary html-boundary :content-type *content-type*
(attachments :content-disposition "inline" :include-blank-line? nil)))
(generate-message-header (attachments
sock :boundary boundary (generate-message-header
:content-type *content-type* :content-disposition "inline" stream :boundary boundary
:include-blank-line? nil)) :content-type *content-type* :content-disposition "inline"
(html-message :include-blank-line? nil))
(generate-message-header (html-message
sock :boundary html-boundary :content-type *content-type* (generate-message-header
:content-disposition "inline")) stream :boundary html-boundary :content-type *content-type*
(t :content-disposition "inline"))
(generate-message-header sock :content-type *content-type* (t
:include-blank-line? nil))) (generate-message-header stream :content-type *content-type*
(write-blank-line sock) :include-blank-line? nil)))
(write-to-smtp sock message) (write-blank-line stream)
(write-blank-line sock) (write-to-smtp stream message)
;;---------- Send Html text if needed ------------------------- (write-blank-line stream)
(when html-message ;;---------- Send Html text if needed -------------------------
(generate-message-header (when html-message
sock :boundary html-boundary (generate-message-header
:content-type "text/html; charset=ISO-8859-1" stream :boundary html-boundary
:content-disposition "inline") :content-type "text/html; charset=ISO-8859-1"
(write-to-smtp sock html-message) :content-disposition "inline")
(send-end-marker sock html-boundary)) (write-to-smtp stream html-message)
;;---------- Send Attachments ----------------------------------- (send-end-marker stream html-boundary))
(when attachments ;;---------- Send Attachments -----------------------------------
(dolist (attachment attachments) (when attachments
(send-attachment sock attachment boundary buffer-size)) (dolist (attachment attachments)
(send-end-marker sock boundary)) (send-attachment stream attachment boundary buffer-size))
(write-char #\. sock) (send-end-marker stream boundary))
(write-blank-line sock) (write-char #\. stream)
(force-output sock) (write-blank-line stream)
(multiple-value-bind (code msgstr) (force-output stream)
(read-from-smtp sock) (multiple-value-bind (code msgstr)
(when (/= code 250) (read-from-smtp stream)
(error "Message send failed: ~A" msgstr))) (when (/= code 250)
(write-to-smtp sock "QUIT") (error "Message send failed: ~A" msgstr)))
(multiple-value-bind (code msgstr) (write-to-smtp stream "QUIT")
(read-from-smtp sock) (multiple-value-bind (code msgstr)
(when (/= code 221) (read-from-smtp stream)
(error "in QUIT command:: ~A" msgstr)))) (when (/= code 221)
(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"
(multiple-value-bind (code msgstr) (usocket::get-host-name)))
(read-from-smtp sock) (multiple-value-bind (code msgstr)
(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)
(caddr authentication))))) #\null (cadr authentication)
(multiple-value-bind (code msgstr) #\null
(read-from-smtp sock) (caddr authentication)))))
(when (/= code 235) (multiple-value-bind (code msgstr)
(error "plain authentication failed: ~A" msgstr)))) (read-from-smtp stream)
((eq (car authentication) :login) (when (/= code 235)
(write-to-smtp sock "AUTH LOGIN") (error "plain authentication failed: ~A" msgstr))))
(multiple-value-bind (code msgstr) ((eq (car authentication) :login)
(read-from-smtp sock) (write-to-smtp stream "AUTH LOGIN")
(when (/= code 334) (multiple-value-bind (code msgstr)
(error "login authentication failed: ~A" msgstr))) (read-from-smtp stream)
(write-to-smtp sock (string-to-base64-string (cadr authentication))) (when (/= code 334)
(multiple-value-bind (code msgstr) (error "login authentication failed: ~A" msgstr)))
(read-from-smtp sock) (write-to-smtp stream (string-to-base64-string (cadr authentication)))
(when (/= code 334) (multiple-value-bind (code msgstr)
(error "login authentication send username failed: ~A" msgstr))) (read-from-smtp stream)
(write-to-smtp sock (string-to-base64-string (caddr authentication))) (when (/= code 334)
(multiple-value-bind (code msgstr) (error "login authentication send username failed: ~A" msgstr)))
(read-from-smtp sock) (write-to-smtp stream (string-to-base64-string (caddr authentication)))
(when (/= code 235) (multiple-value-bind (code msgstr)
(error "login authentication send password failed: ~A" msgstr)))) (read-from-smtp stream)
(t (when (/= code 235)
(error "authentication ~A is not supported in cl-smtp" (error "login authentication send password failed: ~A" msgstr))))
(car authentication))))) (t
(error "authentication ~A is not supported in cl-smtp"
(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