From jidzikowski at common-lisp.net Wed Apr 2 18:02:29 2008
From: jidzikowski at common-lisp.net (jidzikowski)
Date: Wed, 2 Apr 2008 13:02:29 -0500 (EST)
Subject: [cl-smtp-cvs] CVS cl-smtp
Message-ID: <20080402180229.38A1F79145@common-lisp.net>
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]
From jidzikowski at common-lisp.net Wed Apr 2 19:39:59 2008
From: jidzikowski at common-lisp.net (jidzikowski)
Date: Wed, 2 Apr 2008 14:39:59 -0500 (EST)
Subject: [cl-smtp-cvs] CVS cl-smtp
Message-ID: <20080402193959.0231A150A0@common-lisp.net>
Update of /project/cl-smtp/cvsroot/cl-smtp
In directory clnet:/tmp/cvs-serv32398
Added Files:
package.lisp
Log Message:
ups sorry, the package.lisp file from Hans Huebners patch
--- /project/cl-smtp/cvsroot/cl-smtp/package.lisp 2008/04/02 19:39:59 NONE
+++ /project/cl-smtp/cvsroot/cl-smtp/package.lisp 2008/04/02 19:39:59 1.1
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; Lisp Lesser GNU General Public License for more details.
;;; File: package.lisp
;;; Description: cl-smtp package definition file
(in-package :cl-user)
(defpackage :cl-smtp
(:use :cl :asdf :flexi-streams :trivial-gray-streams)
(:export "SEND-EMAIL"
"WITH-SMTP-MAIL"
"SMTP-ERROR"
"SMTP-PROTOCOL-ERROR"
"NO-SUPPORTED-AUTHENTICATION-METHOD"
"RCPT-FAILED"
"IGNORE-RECIPIENT"))
(in-package :cl-smtp)
(defparameter *debug* nil)
(defmacro print-debug (str)
`(when *debug*
(print ,str)))
From jidzikowski at common-lisp.net Thu Apr 3 08:56:33 2008
From: jidzikowski at common-lisp.net (jidzikowski)
Date: Thu, 3 Apr 2008 03:56:33 -0500 (EST)
Subject: [cl-smtp-cvs] CVS cl-smtp
Message-ID: <20080403085633.9E81B81054@common-lisp.net>
Update of /project/cl-smtp/cvsroot/cl-smtp
In directory clnet:/tmp/cvs-serv4564
Modified Files:
CHANGELOG cl-smtp.asd
Log Message:
change version number, wrong date
--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2008/04/02 18:02:28 1.11
+++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2008/04/03 08:56:33 1.12
@@ -1,5 +1,5 @@
-Version 20080202.1
-2007.02.02
+Version 20080402.1
+2007.04.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)
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/02 18:02:29 1.13
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/03 08:56:33 1.14
@@ -17,7 +17,7 @@
;;; Description: cl-smtp ASDF system definition file
(asdf:defsystem :cl-smtp
- :version "20080202.1"
+ :version "20080402.1"
:perform (load-op :after (op webpage)
(pushnew :cl-smtp cl:*features*))
:depends-on (:usocket
From jidzikowski at common-lisp.net Sat Apr 12 19:40:36 2008
From: jidzikowski at common-lisp.net (jidzikowski)
Date: Sat, 12 Apr 2008 15:40:36 -0400 (EDT)
Subject: [cl-smtp-cvs] CVS cl-smtp
Message-ID: <20080412194036.D121F610B6@common-lisp.net>
Update of /project/cl-smtp/cvsroot/cl-smtp
In directory clnet:/tmp/cvs-serv24371
Modified Files:
CHANGELOG cl-smtp.asd cl-smtp.lisp index.html
Log Message:
Fixed TLS directly functionality, switch to ssl stream bevor read from stream.
--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2008/04/03 08:56:33 1.12
+++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2008/04/12 19:40:36 1.13
@@ -1,5 +1,10 @@
+Version 20080412.1
+2008.04.12
+Fixed TLS directly functionality, switch to ssl stream bevor read from stream.
+Change cl-smtp.lisp, cl-smtp.asd, CHANGELOG
+
Version 20080402.1
-2007.04.02
+2008.04.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)
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/03 08:56:33 1.14
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/12 19:40:36 1.15
@@ -2,7 +2,7 @@
;;; This file is part of CL-SMTP, the Lisp SMTP Client
-;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski
+;;; Copyright (C) 2004/2005/2006/2007/2008 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public License
@@ -17,7 +17,7 @@
;;; Description: cl-smtp ASDF system definition file
(asdf:defsystem :cl-smtp
- :version "20080402.1"
+ :version "20080412.1"
:perform (load-op :after (op webpage)
(pushnew :cl-smtp cl:*features*))
:depends-on (:usocket
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2008/04/02 18:02:29 1.12
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2008/04/12 19:40:36 1.13
@@ -266,12 +266,10 @@
to use further down in the conversation, which may be different from
the original stream if we switched to SSL."
- ;; Read the initial greeting from the SMTP server
- (smtp-command stream nil
- 220)
-
(unless (or ssl authentication)
;; Unless we want ESMTP features, perform classic SMTP handshake and return
+ ;; Read the initial greeting from the SMTP server
+ (smtp-command stream nil 220)
(smtp-command stream (format nil "HELO ~A"
(usocket::get-host-name))
250)
@@ -280,7 +278,10 @@
;; When SSL or authentication requested, perform ESMTP EHLO
(let (features)
(labels
- ((do-ehlo ()
+ ((read-greetings ()
+ ;; Read the initial greeting from the SMTP server
+ (smtp-command stream nil 220))
+ (do-ehlo ()
(setf features (rest (smtp-command stream (format nil "EHLO ~A" local-hostname)
250))))
(convert-connection-to-ssl ()
@@ -299,6 +300,7 @@
:latin-1 :eol-style :lf)))))
(ecase ssl
((or t :starttls)
+ (read-greetings)
(do-ehlo)
(unless (find "STARTTLS" features :test #'equal)
(error "this server does not supports TLS"))
@@ -313,8 +315,10 @@
(:tls
;; Plain SSL connection
(convert-connection-to-ssl)
+ (read-greetings)
(do-ehlo))
((nil)
+ (read-greetings)
(do-ehlo))))
(when authentication
(smtp-authenticate stream authentication features)))
--- /project/cl-smtp/cvsroot/cl-smtp/index.html 2007/11/05 19:58:24 1.1
+++ /project/cl-smtp/cvsroot/cl-smtp/index.html 2008/04/12 19:40:36 1.2
@@ -53,7 +53,8 @@
| CMU CL |
- working |
+ working |
+ ssl not working |
| Lispworks |
From jidzikowski at common-lisp.net Thu Apr 17 08:33:55 2008
From: jidzikowski at common-lisp.net (jidzikowski)
Date: Thu, 17 Apr 2008 04:33:55 -0400 (EDT)
Subject: [cl-smtp-cvs] CVS cl-smtp
Message-ID: <20080417083355.3E916300B@common-lisp.net>
Update of /project/cl-smtp/cvsroot/cl-smtp
In directory clnet:/tmp/cvs-serv27009
Modified Files:
CHANGELOG cl-smtp.asd smtp-output-stream.lisp
Log Message:
Fixed stream-element-type. Thanks Attila Lendvai for the bug report.
--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2008/04/12 19:40:36 1.13
+++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2008/04/17 08:33:55 1.14
@@ -1,3 +1,8 @@
+Version 20080417.1
+2008.04.17
+Fixed stream-element-type. Thanks Attila Lendvai for the bug report.
+Change smtp-output-stream, cl-smtp.asd, CHANGELOG
+
Version 20080412.1
2008.04.12
Fixed TLS directly functionality, switch to ssl stream bevor read from stream.
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/12 19:40:36 1.15
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/17 08:33:55 1.16
@@ -17,7 +17,7 @@
;;; Description: cl-smtp ASDF system definition file
(asdf:defsystem :cl-smtp
- :version "20080412.1"
+ :version "20080417.1"
:perform (load-op :after (op webpage)
(pushnew :cl-smtp cl:*features*))
:depends-on (:usocket
--- /project/cl-smtp/cvsroot/cl-smtp/smtp-output-stream.lisp 2008/04/02 18:02:29 1.1
+++ /project/cl-smtp/cvsroot/cl-smtp/smtp-output-stream.lisp 2008/04/17 08:33:55 1.2
@@ -41,7 +41,7 @@
:reader external-format)))
(defmethod stream-element-type ((stream smtp-output-stream))
- (stream-element-type (stream stream)))
+ (stream-element-type (encapsulated-stream stream)))
(defmethod close ((stream smtp-output-stream) &key abort)
(close (encapsulated-stream stream) :abort abort))