Commit bd391bdd authored by Jan Idzikowski's avatar Jan Idzikowski
Browse files

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.
parent 19f2d569
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
......
......@@ -21,8 +21,11 @@ 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) 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
......@@ -40,16 +43,70 @@ To use cl-smtp:
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)
......
......@@ -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)
(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\"" (lookup-mime-type name) name)
: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\"" name)))
: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
......
......@@ -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")))
......@@ -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)))
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)
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
;; -*- Lisp -*-
;; smtp-output-stream.lisp - Perform protocol and mail specific
;; processing to convert an email message into an external format
;; proper to be transfered through SMTP.
;; This stream type is used to do two things:
;; In the message header, convert all non-ASCII characters to their
;; equivalent Q-encoded representation (RFC2047)
;; In the whole message, convert all line endings to CR+LF as required
;; by the SMTP protocol.
;; This stream class should also perform automatic dot masking, tbd.
(in-package :cl-smtp)
(defclass smtp-output-stream (trivial-gray-stream-mixin fundamental-character-output-stream)
((encapsulated-stream
:initarg :encapsulated-stream
:reader encapsulated-stream)
(in-header
:initform t
:accessor in-header
:documentation
"Currently emitting the header of the message")
(line-has-non-ascii
:initform nil
:accessor line-has-non-ascii
:documentation
"The current line has non ASCII characters in it")
(previous-char
:initform nil
:accessor previous-char
:documentation
"Previous character sent to the stream, used to detect end of header")
(external-format
:initform (flex:make-external-format :iso-8859-15)
:initarg :external-format
:reader external-format)))
(defmethod stream-element-type ((stream smtp-output-stream))
(stream-element-type (encapsulated-stream stream)))
(defmethod close ((stream smtp-output-stream) &key abort)
(close (encapsulated-stream stream) :abort abort))
(defmethod stream-write-char ((stream smtp-output-stream) char)
(with-accessors ((in-header in-header)
(line-has-non-ascii line-has-non-ascii)
(previous-char previous-char)
(external-format external-format)
(encapsulated-stream encapsulated-stream)) stream
(when in-header
(cond
;; Newline processing
((eql char #\Newline)
;; Finish quoting
(when line-has-non-ascii
(format encapsulated-stream "?=")
(setf line-has-non-ascii nil))
;; Test for end of header
(when (eql previous-char #\Newline)
(setf in-header nil)))
((eql char #\Return)
;; CR is suppressed here and added before each #\Newline
)
;; Handle non-ASCII characters
((< 127 (char-code char))
(unless line-has-non-ascii
(format encapsulated-stream "=?~A?Q?" (flex:external-format-name external-format))
(setf line-has-non-ascii t))
(loop for byte across (flex:string-to-octets (make-string 1 :initial-element char)
:external-format external-format)
do (format encapsulated-stream "=~2,'0X" byte))))
(setf previous-char char))
#+nil(when (eql char #\Newline)
(write-char #\Return encapsulated-stream))
(unless (< 127 (char-code char))
(write-char char encapsulated-stream))))
(defmethod stream-write-sequence ((stream smtp-output-stream) sequence start end &key)
(if (in-header stream)
(loop for i from start below end
do (stream-write-char stream (elt sequence i)))
(write-sequence sequence (encapsulated-stream stream) :start start :end end)))
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