[cl-smtp-cvs] CVS cl-smtp
jidzikowski
jidzikowski at common-lisp.net
Wed Apr 2 18:02:29 UTC 2008
Update of /project/cl-smtp/cvsroot/cl-smtp
In directory clnet:/tmp/cvs-serv3901
Modified Files:
CHANGELOG README cl-smtp.asd cl-smtp.lisp
Added Files:
smtp-output-stream.lisp
Log Message:
A lot of changes:
- add support for sending raw messages
- add character quoting in email headers (according to RFC2047)
- add condition classes for error reporting
- fixed STARTTLS
- change authentication functionality
See CHANGELOG and source.
Thanks Hans Huebner for these changes.
--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2007/11/11 23:10:21 1.10
+++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2008/04/02 18:02:28 1.11
@@ -1,3 +1,13 @@
+Version 20080202.1
+2007.02.02
+Added support for sending raw messages. (Hans Huebner)
+Fixed STARTTLS so that an EHLO command is sent after STARTTLS. (Hans Huebner)
+Changed Authentication functionality, the actual authentication method used is determined by looking at the advertised features of the SMTP server. (Hans Huebner)
+Added non-ASCII character quoting in email headers (according to RFC2047). (Hans Huebner)
+Added condition classes for error reporting. (Hans Huebner)
+Change cl-smtp.lisp, cl-smtp.asd, CHANGELOG
+Add smtp-output-stream.lisp
+
Version 20071113.1
2007.11.13
Add SSL support, thank Timothy Ritchey for the suggestions.
--- /project/cl-smtp/cvsroot/cl-smtp/README 2007/11/11 23:10:21 1.8
+++ /project/cl-smtp/cvsroot/cl-smtp/README 2008/04/02 18:02:28 1.9
@@ -25,26 +25,29 @@
Arguments:
- host (String) : hostname or ip-adress of the smtpserver
- from (String) : email adress
- - to (String or Cons of Strings) : email adress
+ - to (String or List of Strings) : email adress
- subject (String) : subject text
- message (String) : message body
keywords:
- - cc (String or Cons of Strings) : email adress carbon copy
- - bcc (String or Cons of Strings): email adress blind carbon copy
+ - cc (String or List of Strings) : email adress carbon copy
+ - bcc (String or List of Strings): email adress blind carbon copy
- reply-to (String) : email adress
- displayname (String) : displayname of the sender
- - extra-headers (Cons) : extra headers as alist
+ - extra-headers (List) : extra headers as alist
- html-message (String) : message body formatted with HTML tags
- - authentication (Cons) : list with 3 elements
- (:method "username" "password")
+ - authentication (List) : list with 2 or elements
+ ([:method] "username" "password")
method is a keyword :plain or :login
+ If the method is not specified, the
+ proper method is determined automatically.
- attachments (String or Pathname: attachments to send
- Cons of String/Pathnames)
+ List of String/Pathnames)
- 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
- - ssl (Boolean) : if true than use the STARTTLS functionality to make a ssl connection
+ the number is interpreted in KB
+ - ssl (or t :starttls :tls) : if t or :STARTTLS: use the STARTTLS functionality
+ if :TLS: use TLS directly
Returns nil or error with message
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2007/11/11 23:10:21 1.12
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/02 18:02:29 1.13
@@ -16,25 +16,18 @@
;;; File: cl-smtp.asd
;;; Description: cl-smtp ASDF system definition file
-(defpackage :cl-smtp
- (:use :cl :asdf)
- (:export :send-email))
-
-(in-package :cl-smtp)
-
-(defparameter *debug* nil)
-
-(defmacro print-debug (str)
- `(when *debug*
- (print ,str)))
-
(asdf:defsystem :cl-smtp
- :version "20071113.1"
- :perform (load-op :after (op webpage)
- (pushnew :cl-smtp cl:*features*))
- :depends-on (:usocket #-allegro :cl-base64
- #-allegro :flexi-streams
- #-allegro :cl+ssl)
- :components ((:file "cl-smtp" :depends-on ("attachments"))
- (:file "attachments")
- (:file "mime-types")))
+ :version "20080202.1"
+ :perform (load-op :after (op webpage)
+ (pushnew :cl-smtp cl:*features*))
+ :depends-on (:usocket
+ :trivial-gray-streams
+ :flexi-streams
+ #-allegro :cl-base64
+ #-allegro :cl+ssl)
+ :serial t
+ :components ((:file "package")
+ (:file "attachments")
+ (:file "cl-smtp")
+ (:file "smtp-output-stream")
+ (:file "mime-types")))
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2007/11/11 23:10:21 1.11
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2008/04/02 18:02:29 1.12
@@ -34,21 +34,23 @@
(t
(error "the \"~A\" argument is not a string or cons" name))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *line-with-one-dot* #.(format nil "~C~C.~C~C" #\Return #\NewLine
+ #\Return #\NewLine))
+ (defvar *line-with-two-dots* #.(format nil "~C~C..~C~C" #\Return #\NewLine
+ #\Return #\NewLine)))
+
(defun mask-dot (str)
- "replace \r\n.\r\n with \r\n..\r\n"
- (let ((dotstr (format nil "~C~C.~C~C" #\Return #\NewLine
- #\Return #\NewLine))
- (maskdotsr (format nil "~C~C..~C~C" #\Return #\NewLine
- #\Return #\NewLine))
- (resultstr ""))
+ "Replace all occurences of \r\n.\r\n in STR with \r\n..\r\n"
+ (let ((resultstr ""))
(labels ((mask (tempstr)
- (let ((n (search dotstr tempstr)))
+ (let ((n (search *line-with-one-dot* tempstr)))
(cond
(n
(setf resultstr (concatenate 'string resultstr
(subseq tempstr 0 n)
- maskdotsr))
- (mask (subseq tempstr (+ n 5))))
+ *line-with-two-dots*))
+ (mask (subseq tempstr (+ n #.(length *line-with-one-dot*)))))
(t
(setf resultstr (concatenate 'string resultstr
tempstr)))))))
@@ -60,11 +62,76 @@
#+allegro (excl:string-to-base64-string str)
#-allegro (cl-base64:string-to-base64-string str))
+(define-condition smtp-error (error)
+ ())
+
+(define-condition smtp-protocol-error (smtp-error)
+ ((command :initarg :command :reader command)
+ (expected-response-code :initarg :expected-response-code :reader expected-response-code)
+ (response-code :initarg :response-code :reader response-code)
+ (response-message :initarg :response-message :reader response-message))
+ (:report (lambda (condition stream)
+ (print-unreadable-object (condition stream :type t)
+ (format stream "a command failed:~%command: ~S expected: ~A response: ~A"
+ (command condition)
+ (expected-response-code condition)
+ (response-message condition))))))
+
+(define-condition rcpt-failed (smtp-protocol-error)
+ ((recipient :initarg :recipient
+ :reader recipient))
+ (:report (lambda (condition stream)
+ (print-unreadable-object (condition stream :type t)
+ (format stream "while trying to send email through SMTP, the server rejected the recipient ~A: ~A"
+ (recipient condition)
+ (response-message condition))))))
+
+(defun smtp-command (stream command expected-response-code
+ &key (condition-class 'smtp-protocol-error)
+ condition-arguments)
+ (when command
+ (write-to-smtp stream command))
+ (multiple-value-bind (code msgstr lines)
+ (read-from-smtp stream)
+ (when (/= code expected-response-code)
+ (apply #'error
+ condition-class
+ (append condition-arguments
+ (list :command command
+ :expected-response-code expected-response-code
+ :response-code code
+ :response-message msgstr))))
+ lines))
+
+(defun do-with-smtp-mail (host from to thunk &key port authentication ssl local-hostname)
+ (usocket:with-client-socket (socket stream host port)
+ (let ((stream (smtp-handshake stream
+ :authentication authentication
+ :ssl ssl
+ :local-hostname local-hostname)))
+ (initiate-smtp-mail stream from to)
+ (funcall thunk (make-instance 'smtp-output-stream :encapsulated-stream stream))
+ (finish-smtp-mail stream))))
+
+(defmacro with-smtp-mail ((stream-var host from to &key ssl (port (if (eq :tls ssl) 465 25)) authentication local-hostname)
+ &body body)
+ "Encapsulate a SMTP MAIl conversation. A connection to the SMTP
+ server on HOST and PORT is established and a MAIL command is
+ initiated with FROM being the mail sender and TO being the list of
+ recipients. BODY is evaluated with STREAM-VAR being the stream
+ connected to the remote SMTP server. BODY is expected to write the
+ RFC2821 message (headers and body) to STREAM-VAR."
+ `(do-with-smtp-mail ,host ,from ,to
+ (lambda (,stream-var) , at body)
+ :port ,port
+ :authentication ,authentication
+ :ssl ,ssl
+ :local-hostname ,local-hostname))
(defun send-email (host from to subject message
- &key (port 25) cc bcc reply-to extra-headers
+ &key ssl (port (if (eq :tls ssl) 465 25)) cc bcc reply-to extra-headers
html-message display-name authentication
- attachments (buffer-size 256) ssl)
+ attachments (buffer-size 256))
(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
@@ -78,186 +145,216 @@
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 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
- (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 (stream &key authentication ssl)
- (multiple-value-bind (code msgstr)
- (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 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 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 stream (format nil "HELO ~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)))))
+(defun send-smtp (host from to subject message
+ &key ssl (port (if (eq :tls ssl) 465 25)) cc bcc
+ reply-to extra-headers html-message display-name
+ authentication attachments buffer-size
+ (local-hostname (usocket::get-host-name)))
+ (with-smtp-mail (stream host from (append to cc bcc)
+ :port port
+ :authentication authentication
+ :ssl ssl
+ :local-hostname local-hostname)
+ (let* ((boundary (make-random-boundary))
+ (html-boundary (if (and attachments html-message)
+ (make-random-boundary)
+ boundary)))
+ (send-mail-headers stream
+ :from from
+ :to to
+ :cc cc
+ :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)))))
+
+(define-condition no-supported-authentication-method (smtp-error)
+ ((features :initarg :features :reader features))
+ (:report (lambda (condition stream)
+ (print-unreadable-object (condition stream :type t)
+ (format stream "SMTP authentication has been requested, but the SMTP server did not advertise any ~
+ supported authentication scheme. Features announced: ~{~S~^, ~}"
+ (features condition))))))
+
+(defun smtp-authenticate (stream authentication features)
+ "Authenticate to the SMTP server connected on STREAM.
+ AUTHENTICATION is a list of two or three elements. If the first
+ element is a keyword, it specifies the desired authentication
+ method (:PLAIN or :LOGIN), which is currently ignored. The actual
+ method used is determined by looking at the advertised features of
+ the SMTP server. The (other) two elements of the AUTHENTICATION
+ list are the login username and password. FEATURES is the list of
+ features announced by the SMTP server.
+
+ If the server does not announce any compatible authentication scheme,
+ the NO-SUPPORTED-AUTHENTICATION-METHOD error is signalled."
+ (when (keywordp (car authentication))
+ (pop authentication))
+ (let ((server-authentication (loop for i in features
+ for e = (search "AUTH " i :test #'equal)
+ when (and e (= e 0))
+ return i)))
+ (destructuring-bind (username password) authentication
+ (cond
+ ((search " PLAIN" server-authentication :test #'equal)
+ (smtp-command stream (format nil "AUTH PLAIN ~A"
+ (string-to-base64-string
+ (format nil "~A~C~A~C~A"
+ username
+ #\null username
+ #\null password)))
+ 235))
+ ((search " LOGIN" server-authentication :test #'equal)
+ (smtp-command stream "AUTH LOGIN"
+ 334)
+ (smtp-command stream (string-to-base64-string username)
+ 334)
+ (smtp-command stream (string-to-base64-string password)
+ 235))
+ (t
+ (error 'no-supported-authentication-method :features features))))))
+
+(defun smtp-handshake (stream &key authentication ssl local-hostname)
+ "Perform the initial SMTP handshake on STREAM. Returns the stream
+ to use further down in the conversation, which may be different from
+ the original stream if we switched to SSL."
+
[150 lines skipped]
--- /project/cl-smtp/cvsroot/cl-smtp/smtp-output-stream.lisp 2008/04/02 18:02:29 NONE
+++ /project/cl-smtp/cvsroot/cl-smtp/smtp-output-stream.lisp 2008/04/02 18:02:29 1.1
[237 lines skipped]
More information about the Cl-smtp-cvs
mailing list