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
2007.11.04
Fixed bug with the file attachments to solve corrupted files when
......@@ -5,7 +11,7 @@ processed with chunking turned on. (Brian Sorg)
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
......
......@@ -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
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 @@ To use cl-smtp:
(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 @@ To use cl-smtp:
- 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
......
......@@ -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")))
......@@ -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))
(write-string command stream)
(write-char #\Return stream)
(write-char #\NewLine stream)
(force-output stream))
(defun write-blank-line (sock)
(write-char #\Return sock)
(write-char #\NewLine sock)
(force-output sock))
(defun write-blank-line (stream)
(write-char #\Return stream)
(write-char #\NewLine stream)
(force-output stream))
(defun read-from-smtp (sock)
(let* ((line (read-line sock))
(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))))
(read-from-smtp stream (append lines (list response)))
(values response-code line lines))))
(defun get-email-date-string ()
(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