[cl-smtp-cvs] CVS cl-smtp
jidzikowski
jidzikowski at common-lisp.net
Thu May 6 09:24:43 UTC 2010
Update of /project/cl-smtp/cvsroot/cl-smtp
In directory cl-net:/tmp/cvs-serv31991
Modified Files:
CHANGELOG README attachments.lisp cl-smtp.asd cl-smtp.lisp
mime-types.lisp package.lisp
Removed Files:
smtp-output-stream.lisp
Log Message:
Rewrite encoding functions, now it is possible to use non ascii characters in
header values and in attachment filenames.
New keyword argument external-format (default :utf-8).
New class attachment, with slots attachment-name and
attachment-mime-type, and a constructor function make-attachment.
Rename q-encode-str to rfc2045-q-encode-string.
Add rfc2231-encode-string to encode non ascii characters
in attachment filenames.
--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/04/22 10:51:34 1.16
+++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/05/06 09:24:43 1.17
@@ -1,7 +1,23 @@
+Version 20100505.1
+2010.05.05
+Rewrite encoding functions, now it is possible to use non ascii characters in
+header values and in attachment filenames.
+New keyword argument external-format (default :utf-8).
+New class attachment, with slots attachment-name and
+attachment-mime-type, and a constructor function make-attachment.
+Rename q-encode-str to rfc2045-q-encode-string.
+Add rfc2231-encode-string to encode non ascii characters
+in attachment filenames.
+Add tests for encoding functions, see tests.lisp.
+Change cl-smtp.lisp, attachment.lisp, package.lisp,
+ cl-smtp.asd, CHANGELOG, README
+Add tests.lisp
+Remove smtp-output-stream.lisp
+
Version 20100422.1
2010.04.22
Fixed encoding errors in header strings,
-new function q-encode-str to encode strings in header
+new function q-encode-str to encode strings in header.
Change cl-smtp.lisp, CHANGELOG
Version 20100420.1
--- /project/cl-smtp/cvsroot/cl-smtp/README 2008/04/02 18:02:28 1.9
+++ /project/cl-smtp/cvsroot/cl-smtp/README 2010/05/06 09:24:43 1.10
@@ -21,14 +21,17 @@
(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) ssl)
+Send email.
- Arguments:
+Returns nil or error with message
+
+ arguments:
- host (String) : hostname or ip-adress of the smtpserver
- from (String) : email adress
- to (String or List of Strings) : email adress
- subject (String) : subject text
- message (String) : message body
- keywords:
+ keywords:
- 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
@@ -40,16 +43,70 @@
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
- List of String/Pathnames)
+ - attachments (Attachment Instance or String or Pathname: attachments to send
+ List of Attachment/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 interpreted in KB
- ssl (or t :starttls :tls) : if t or :STARTTLS: use the STARTTLS functionality
if :TLS: use TLS directly
+ - external-format : symbol, default :utf-8
-Returns nil or error with message
+------------------------------------------------
+
+(cl-smtp:rfc2045-q-encode-string str &key (external-format :utf8))
+
+Decodes a string to an quoted-printable string.
+
+Returns quoted-printable string
+
+ arguments:
+ - str : the string to encode
+ keywords:
+ - external-format : symbol, default :utf-8
+
+------------------------------------------------
+
+(cl-smtp:rfc2231-encode-string str &key (external-format :utf8))
+
+Decodes a string to an rfc2231 encode string.
+
+Returns rfc2231 encode string
+
+ arguments:
+ - str : the string to encode
+ keywords:
+ - external-format : symbol, default :utf-8
+
+------------------------------------------------
+CLASS
+cl-smtp:attachment
+
+ - accessor: attachment-name : string
+ - accessor: attachment-data-pathname : pathname
+ - accessor: attachment-mime-type : string (mime-type)
+
+It is now possible to send a file under a different name.
+See cl-smtp:make-attachment.
+------------------------------------------------
+
+(cl-smtp:make-attachment data-pathname
+ &key (name (file-namestring data-pathname))
+ (mime-type (lookup-mime-type name)))
+
+Create a instance of cl-smtp:attachment.
+
+Returns cl-smtp:attachment
+
+ arguments:
+ - data-pathname : pathname
+ keywords:
+ - name : string,
+ default (file-namestring data-pathname)
+ - mime-type : string,
+ default (lookup-mime-type name)
+------------------------------------------------
For debug output set the parameter *debug* to t (default nil)
(setf cl-smtp::*debug* t)
--- /project/cl-smtp/cvsroot/cl-smtp/attachments.lisp 2010/04/20 10:10:58 1.7
+++ /project/cl-smtp/cvsroot/cl-smtp/attachments.lisp 2010/05/06 09:24:43 1.8
@@ -3,7 +3,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/2009/2010 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
@@ -69,24 +69,91 @@
content-transfer-encoding)))
(when include-blank-line? (write-blank-line sock)))
-(defun send-attachment-header (sock boundary name)
-
- (generate-message-header
- sock
- :boundary boundary
- :content-type (format nil "~a;~%~tname=\"~a\"" (lookup-mime-type name) name)
- :content-transfer-encoding "base64"
- :content-disposition (format nil "attachment; filename=\"~a\"" name)))
+(defun escape-rfc822-quoted-string (str)
+ (with-output-to-string (s)
+ (loop
+ for c across str do
+ (when (find (char-code c) '(10 13 92 34))
+ (write-char #\\ s))
+ (write-char c s))))
+
+(defun rfc2231-encode-string (string &key (external-format :utf-8))
+ (with-output-to-string (s)
+ (format s "~A''" (string-upcase (symbol-name external-format)))
+ (loop for n across (string-to-octets string
+ :external-format external-format)
+ for c = (code-char n)
+ do (cond ((or (char<= #\0 c #\9)
+ (char<= #\a c #\z)
+ (char<= #\A c #\Z)
+ (find c "$-_.!*'()," :test #'char=))
+ (write-char c s))
+ ((char= c #\Space)
+ (write-char #\+ s))
+ (t (format s "%~2,'0x" (char-code c)))))))
+
+(defun send-attachment-header (sock boundary attachment external-format)
+ (let ((quoted-name
+ (escape-rfc822-quoted-string
+ (rfc2045-q-encode-string (attachment-name attachment)
+ :external-format external-format)))
+ (quoted-name*
+ (escape-rfc822-quoted-string
+ (rfc2231-encode-string (attachment-name attachment)
+ :external-format external-format))))
+ (generate-message-header
+ sock
+ :boundary boundary
+ :content-type (format nil "~A;~%~tname*=~A;~%~tname=~S"
+ (attachment-mime-type attachment)
+ quoted-name* quoted-name)
+ :content-transfer-encoding "base64"
+ :content-disposition (format nil "attachment; filename*=~A; filename=~S"
+ quoted-name* quoted-name))))
(defun send-end-marker (sock boundary)
;; Note the -- at beginning and end of boundary is required
(write-to-smtp sock (format nil "~%--~a--~%" boundary)))
-(defun send-attachment (sock attachment boundary buffer-size)
- (when (probe-file attachment)
- (let ((name (file-namestring attachment)))
- (send-attachment-header sock boundary name)
- (base64-encode-file attachment sock :buffer-size buffer-size))))
+(defclass attachment ()
+ ((name :initarg :name
+ :accessor attachment-name)
+ (data-pathname :initarg :data-pathname
+ :accessor attachment-data-pathname)
+ (mime-type :initarg :mime-type
+ :accessor attachment-mime-type)))
+
+(defun make-attachment (data-pathname
+ &key (name (file-namestring data-pathname))
+ (mime-type (lookup-mime-type name)))
+ (make-instance 'attachment
+ :data-pathname data-pathname
+ :name name
+ :mime-type mime-type))
+
+(defmethod attachment-name ((attachment pathname))
+ (file-namestring attachment))
+
+(defmethod attachment-data-pathname ((attachment pathname))
+ attachment)
+
+(defmethod attachment-mime-type ((attachment pathname))
+ (lookup-mime-type (namestring attachment)))
+
+(defmethod attachment-name ((attachment string))
+ (file-namestring attachment))
+
+(defmethod attachment-data-pathname ((attachment string))
+ attachment)
+
+(defmethod attachment-mime-type ((attachment string))
+ (lookup-mime-type attachment))
+
+(defun send-attachment (sock attachment boundary buffer-size external-format)
+ (send-attachment-header sock boundary attachment external-format)
+ (base64-encode-file (attachment-data-pathname attachment)
+ sock
+ :buffer-size buffer-size))
(defun base64-encode-file (file-in sock
&key
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/17 08:33:55 1.16
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2010/05/06 09:24:43 1.17
@@ -2,7 +2,7 @@
;;; This file is part of CL-SMTP, the Lisp SMTP Client
-;;; Copyright (C) 2004/2005/2006/2007/2008 Jan Idzikowski
+;;; Copyright (C) 2004/2005/2006/2007/2008/2009/2010 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 "20080417.1"
+ :version "20100505.1"
:perform (load-op :after (op webpage)
(pushnew :cl-smtp cl:*features*))
:depends-on (:usocket
@@ -29,5 +29,5 @@
:components ((:file "package")
(:file "attachments")
(:file "cl-smtp")
- (:file "smtp-output-stream")
- (:file "mime-types")))
+ (:file "mime-types")
+ (:file "tests")))
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/04/22 10:51:34 1.14
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/05/06 09:24:43 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/2009/2010 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
@@ -18,8 +18,6 @@
(in-package :cl-smtp)
-(defparameter *content-type* "text/plain; charset=ISO-8859-1")
-
(defparameter *x-mailer* (format nil "(~A ~A)"
(lisp-implementation-type)
(lisp-implementation-version)))
@@ -38,7 +36,8 @@
(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)))
+ #\Return #\NewLine))
+ (defvar *return-newline* #.(format nil "~C~C" #\Return #\NewLine)))
(defun mask-dot (str)
"Replace all occurences of \r\n.\r\n in STR with \r\n..\r\n"
@@ -62,19 +61,20 @@
#+allegro (excl:string-to-base64-string str)
#-allegro (cl-base64:string-to-base64-string str))
-(defun q-encode-str (str &key (external-format
- (flex:make-external-format :iso-8859-15)))
- (let ((line-has-non-ascii nil))
+(defun rfc2045-q-encode-string (str &key (external-format :utf-8))
+ (let ((line-has-non-ascii nil)
+ (exformat (flex:make-external-format external-format)))
(with-output-to-string (s)
(loop for c across str do
(cond
((< 127 (char-code c))
(unless line-has-non-ascii
- (format s "=?~A?Q?" (flex:external-format-name external-format))
+ (format s "=?~A?Q?"
+ (string-upcase (symbol-name external-format)))
(setf line-has-non-ascii t))
(loop for byte across (flex:string-to-octets
(make-string 1 :initial-element c)
- :external-format external-format)
+ :external-format exformat)
do (format s "=~2,'0X" byte)))
(t
(when line-has-non-ascii
@@ -84,6 +84,23 @@
(when line-has-non-ascii
(format s "?=")))))
+(defun substitute-return-newline (str)
+ "Replace all occurences of \r\n in STR with spaces"
+ (let ((resultstr ""))
+ (labels ((mask (tempstr)
+ (let ((n (search *return-newline* tempstr)))
+ (cond
+ (n
+ (setf resultstr (concatenate 'string resultstr
+ (subseq tempstr 0 n)
+ " "))
+ (mask (subseq tempstr (+ n 2))))
+ (t
+ (setf resultstr (concatenate 'string resultstr
+ tempstr)))))))
+ (mask str))
+ resultstr))
+
(define-condition smtp-error (error)
())
@@ -94,9 +111,10 @@
(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"
+ (format stream "a command failed:~%command: ~S expected: ~A response-code: ~A response-message: ~A"
(command condition)
(expected-response-code condition)
+ (response-code condition)
(response-message condition))))))
(define-condition rcpt-failed (smtp-protocol-error)
@@ -125,23 +143,24 @@
:response-message msgstr))))
lines))
-(defun do-with-smtp-mail (host from to thunk &key port authentication ssl local-hostname)
+(defun do-with-smtp-mail (host from to thunk &key port authentication ssl
+ local-hostname (external-format :utf-8))
(usocket:with-client-socket (socket stream host port
:element-type '(unsigned-byte 8))
(setf stream (flexi-streams:make-flexi-stream
- stream
- :external-format
- (flexi-streams:make-external-format
- :latin-1 :eol-style :lf)))
+ stream
+ :external-format
+ (flexi-streams:make-external-format
+ external-format :eol-style :lf)))
(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))
+ (funcall thunk 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)
+(defmacro with-smtp-mail ((stream-var host from to &key ssl (port (if (eq :tls ssl) 465 25)) authentication local-hostname (external-format :utf-8))
&body body)
"Encapsulate a SMTP MAIl conversation. A connection to the SMTP
server on HOST and PORT is established and a MAIL command is
@@ -154,12 +173,13 @@
:port ,port
:authentication ,authentication
:ssl ,ssl
- :local-hostname ,local-hostname))
+ :local-hostname ,local-hostname
+ :external-format ,external-format))
(defun send-email (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 256))
+ attachments (buffer-size 256) (external-format :utf-8))
(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
@@ -171,23 +191,28 @@
:buffer-size (if (numberp buffer-size)
buffer-size
256)
+ :external-format external-format
:ssl ssl))
(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)))
+ (local-hostname (usocket::get-host-name))
+ (external-format :utf-8))
(with-smtp-mail (stream host from (append to cc bcc)
:port port
:authentication authentication
:ssl ssl
- :local-hostname local-hostname)
- (setf (in-header stream) nil)
+ :local-hostname local-hostname
+ :external-format external-format)
(let* ((boundary (make-random-boundary))
(html-boundary (if (and attachments html-message)
(make-random-boundary)
- boundary)))
+ boundary))
+ (content-type
+ (format nil "text/plain; charset=~S"
+ (string-upcase (symbol-name external-format)))))
(send-mail-headers stream
:from from
:to to
@@ -213,19 +238,19 @@
:multipart-type "alternative")
(write-blank-line stream)
(generate-message-header
- stream :boundary html-boundary :content-type *content-type*
+ 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"
+ :content-type content-type :content-disposition "inline"
:include-blank-line? nil))
(html-message
(generate-message-header
- stream :boundary html-boundary :content-type *content-type*
+ stream :boundary html-boundary :content-type content-type
:content-disposition "inline"))
(t
- (generate-message-header stream :content-type *content-type*
+ (generate-message-header stream :content-type content-type
:include-blank-line? nil)))
(write-blank-line stream)
(write-to-smtp stream message)
@@ -234,14 +259,16 @@
(when html-message
(generate-message-header
stream :boundary html-boundary
- :content-type "text/html; charset=ISO-8859-1"
+ :content-type (format nil "text/html; charset=~S"
+ (string-upcase (symbol-name external-format)))
: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-attachment stream attachment boundary buffer-size
+ external-format))
(send-end-marker stream boundary)))))
(define-condition no-supported-authentication-method (smtp-error)
@@ -300,7 +327,7 @@
;; Read the initial greeting from the SMTP server
(smtp-command stream nil 220)
(smtp-command stream (format nil "HELO ~A"
- (usocket::get-host-name))
+ (usocket::get-host-name))
250)
(return-from smtp-handshake stream))
@@ -362,11 +389,12 @@
is signalled. This condition may be handled by the caller in order
to send the email anyway."
(smtp-command stream
- (format nil "MAIL FROM:<~A>" from)
+ (format nil "MAIL FROM:<~A>" (substitute-return-newline from))
250)
(dolist (address to)
(restart-case
- (smtp-command stream (format nil "RCPT TO:<~A>" address)
+ (smtp-command stream (format nil "RCPT TO:<~A>"
+ (substitute-return-newline address))
250
:condition-class 'rcpt-failed
:condition-arguments (list :recipient address))
@@ -384,23 +412,31 @@
(defun send-mail-headers (stream
&key from to cc reply-to
- extra-headers display-name subject)
+ extra-headers display-name subject
+ (external-format :utf-8))
"Send email headers according to the given arguments to the SMTP
server connected to on STREAM. The server is expected to have
previously accepted the DATA SMTP command."
(write-to-smtp stream (format nil "Date: ~A" (get-email-date-string)))
(if display-name
(write-to-smtp stream (format nil "From: ~A <~A>"
- (q-encode-str display-name) from))
+ (rfc2045-q-encode-string
+ display-name :external-format external-format)
+ from))
(write-to-smtp stream (format nil "From: ~A" from)))
(write-to-smtp stream (format nil "To: ~{ ~a~^,~}" to))
(when cc
(write-to-smtp stream (format nil "Cc: ~{ ~a~^,~}" cc)))
- (write-to-smtp stream (format nil "Subject: ~A" (q-encode-str subject)))
- (write-to-smtp stream (format nil "X-Mailer: cl-smtp ~A"
- (q-encode-str *x-mailer*)))
+ (write-to-smtp stream (format nil "Subject: ~A"
+ (rfc2045-q-encode-string
+ subject :external-format external-format)))
+ (write-to-smtp stream (format nil "X-Mailer: cl-smtp~A"
+ (rfc2045-q-encode-string
+ *x-mailer* :external-format external-format)))
(when reply-to
- (write-to-smtp stream (format nil "Reply-To: ~A" reply-to)))
+ (write-to-smtp stream (format nil "Reply-To: ~A"
+ (rfc2045-q-encode-string
+ reply-to :external-format external-format))))
(when (and extra-headers
(listp extra-headers))
(dolist (l extra-headers)
--- /project/cl-smtp/cvsroot/cl-smtp/mime-types.lisp 2007/11/03 23:53:29 1.1
+++ /project/cl-smtp/cvsroot/cl-smtp/mime-types.lisp 2010/05/06 09:24:43 1.2
@@ -3,7 +3,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/2009/2010 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
--- /project/cl-smtp/cvsroot/cl-smtp/package.lisp 2008/04/02 19:39:59 1.1
+++ /project/cl-smtp/cvsroot/cl-smtp/package.lisp 2010/05/06 09:24:43 1.2
@@ -26,7 +26,14 @@
"SMTP-PROTOCOL-ERROR"
"NO-SUPPORTED-AUTHENTICATION-METHOD"
"RCPT-FAILED"
- "IGNORE-RECIPIENT"))
+ "IGNORE-RECIPIENT"
+ "ATTACHMENT"
+ "MAKE-ATTACHMENT"
+ "ATTACHMENT-NAME"
+ "ATTACHMENT-DATA-PATHNAME"
+ "ATTACHMENT-MIME-TYPE"
+ "RFC2045-Q-ENCODE-STRING"
+ "RFC2231-ENCODE-STRING"))
(in-package :cl-smtp)
More information about the Cl-smtp-cvs
mailing list