Commit 10018ea9 authored by Jan Idzikowski's avatar Jan Idzikowski
Browse files

Fixed bug with the file attachments to solve corrupted files when

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)
parent 81327d3b
Version 20071104.1
2007.11.04
Fixed bug with the file attachments to solve corrupted files when
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
Add mime-type.lisp
Version 20071018.1
2007.10.18
Reverted the non allegro base64 functionality in attachment.lisp,
......
......@@ -17,8 +17,8 @@ To use cl-smtp:
------------------------------------------------
(cl-smtp:send-email host from to subject message
&key (port 25) cc bcc reply-to extra-headers authentication
attachments (buffer-size 256))
&key (port 25) cc bcc reply-to extra-headers html-message
authentication attachments (buffer-size 256))
Arguments:
- host (String) : hostname or ip-adress of the smtpserver
......@@ -32,6 +32,7 @@ To use cl-smtp:
- reply-to (String) : email adress
- displayname (String) : displayname of the sender
- extra-headers (Cons) : extra headers as alist
- html-message (String) : message body formatted with HTML tags
- authentication (Cons) : list with 3 elements
(:method "username" "password")
method is a keyword :plain or :login
......
......@@ -37,98 +37,131 @@
(dotimes (i (length chars) arr)
(setf (aref arr i) (pop chars)))))
(defun make-random-boundary (&optional (length 50) (boundary-chars *boundary-chars*))
(defun make-random-boundary (&optional (length 30)
(boundary-chars *boundary-chars*))
(let ((boundary (make-string length))
(prefix "_---------_")
(chars-length (length boundary-chars)))
(dotimes (i length boundary)
(setf (aref boundary i) (svref *boundary-chars* (random chars-length))))))
(dotimes (i length (concatenate 'string prefix boundary))
(setf (aref boundary i)
(svref *boundary-chars* (random chars-length))))))
(defun generate-multipart-header (sock boundary)
(defun generate-multipart-header (sock boundary &key (multipart-type "mixed"))
(write-to-smtp sock
(format nil "Content-type: multipart/mixed;~%~tBoundary=\"~a\""
boundary)))
(format nil "Content-type: multipart/~a;~%~tBoundary=\"~a\""
multipart-type boundary)))
(defun generate-message-header (sock
&key boundary ;; uniques string of character -- see make-random-boundary
content-type ;; "text/plain; charset=ISO-8859-1"
content-disposition ;; inline attachment
content-transfer-encoding ;; 7 bit or 8 bit
(include-blank-line? t))
(when boundary
(write-to-smtp sock (format nil "--~a" boundary)))
(when content-type
(write-to-smtp sock (format nil "Content-type: ~a" content-type)))
(when content-disposition
(write-to-smtp sock (format nil "Content-Disposition: ~A"
content-disposition)))
(when content-transfer-encoding
(write-to-smtp sock (format nil "Content-Transfer-Encoding: ~A"
content-transfer-encoding)))
(when include-blank-line? (write-blank-line sock)))
(defun send-attachment-header (sock boundary name)
(defun wrap-message-with-multipart-dividers (message boundary)
(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)))
(concatenate 'string (format nil "--~a~%" boundary)
(format nil "Content-type: text/plain~%")
(format nil "Content-Disposition: inline~%")
(format nil "~%")
message (format nil "~%")))
(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)
(print-debug (format nil "Sending attachment: ~a" attachment))
(when (probe-file attachment)
(let ((name (file-namestring attachment)))
(send-attachment-header sock boundary name)
(base64-encode-file attachment sock :buffer-size buffer-size)
)))
(defun send-attachment-header (sock boundary name)
(base64-encode-file attachment sock :buffer-size buffer-size))))
(write-to-smtp sock
(format nil "~%--~a~%Content-type: application/octet-stream;~%~tname=\"~a\"~%Content-Transfer-Encoding: base64~%Content-Disposition: attachment; filename=\"~a\"~%"
boundary
name
name)))
(defun send-attachments-end-marker (sock boundary)
(write-to-smtp sock
(format nil "~%--~a--~%" boundary)))
(defun base64-encode-file (file-in sock
&key
(buffer-size 256) ;; in KB
(wrap-at-column 76))
(declare (ignorable wrap-at-column))
(let* ((max-buffer-size (* buffer-size 1024))
(byte-count 0)
(buffer (make-array max-buffer-size
:element-type '(unsigned-byte 8))))
(wrap-at-column 70))
"Encodes the file contents given by file-in, which can be of any form appropriate to with-open-file, and write the base-64 encoded version to sock, which is a socket.
Buffer-size, given in KB, controls how much of the file is processed and written to the socket at one time. A buffer-size of 0, processes the file all at once, regardless of its size. One will have to weigh the speed vs, memory consuption risks when chosing which way is best.
Wrap-at-column controls where the encode string is divided for line breaks."
(when (probe-file file-in)
;;-- open filein ---------
(with-open-file (strm-in file-in
:element-type '(unsigned-byte 8))
(loop
(setq byte-count 0)
;; read a portion of the file into the buffer
(setq byte-count (dotimes (i max-buffer-size max-buffer-size)
(let ((bchar (read-byte strm-in nil 'EOF)))
(if (eql bchar 'EOF)
(return i)
(setf (aref buffer i) bchar)))))
(print-debug (format nil "~%** Byte Count ~a~%" byte-count))
;; encode the buffer and write out to stream
#+allegro
(write-string (excl:usb8-array-to-base64-string
(if (< byte-count max-buffer-size)
(trimmed-buffer byte-count buffer)
buffer)
wrap-at-column) sock)
#-allegro
(cl-base64:usb8-array-to-base64-stream
(if (< byte-count max-buffer-size)
(trimmed-buffer byte-count buffer)
buffer)
sock :columns wrap-at-column)
(force-output sock)
;;-- when finished reading exit do loop
(when (< byte-count max-buffer-size)
(return)))))))
(defun trimmed-buffer (byte-count buffer)
"Creates an array the length of byte-count and copies contents of buffer into it.
Needed in Lispworks, Lispworks initialized all elements of the buffer array when it was made, allegro doesn't
seem to have this behavior"
(let ((trimmed-buffer (make-array byte-count :element-type '(unsigned-byte 8))))
(dotimes (i byte-count trimmed-buffer)
(setf (aref trimmed-buffer i) (aref buffer i)))))
(let* ((;; convert buffer size given to bytes
;; or compute bytes based on file
max-buffer-size
(if (zerop buffer-size)
(file-length strm-in)
;; Ensures 64 bit encoding is properly
;; divided so that filler
;; characters are not required between chunks
(* 24 (truncate (/ (* buffer-size 1024) 24)))))
(column-count 0)
(eof? nil)
(buffer (make-array max-buffer-size
:element-type '(unsigned-byte 8))))
(loop
(print-debug (format nil "~%Process attachment ~a~%" file-in))
(let* ((;; read a portion of the file into the buffer arrary and
;; returns the index where it stopped
byte-count (dotimes (i max-buffer-size max-buffer-size)
(let ((bchar (read-byte strm-in nil 'EOF)))
(if (eql bchar 'EOF)
(progn
(setq eof? t)
(return i))
(setf (aref buffer i) bchar))))))
(if (zerop buffer-size)
;; send file all at once to socket.
#+allegro
(write-string (excl:usb8-array-to-base64-string
buffer wrap-at-column) sock)
#-allegro
(cl-base64:usb8-array-to-base64-stream
buffer sock :columns wrap-at-column)
;; otherwise process file in chunks.
;; The extra encoded-string,
;; and its subseq functions are brute force methods
;; to properly handle the wrap-at-column feature
;; between buffers.
;; Not the most efficient way,
;; but it works and uses existing functions
;; in the cl-base64 package.
(let* ((;; drops off extra elements that were not filled in in reading, this is important for lisp systems that default a value into
;; the array when it is created. -- ie Lispworks, SBCL
trimmed-buffer (if eof?
(subseq buffer 0 byte-count)
buffer))
(encoded-string
#+allegro
(cl-base64:usb8-array-to-base64-string
trimmed-buffer)
#-allegro
(cl-base64:usb8-array-to-base64-string
trimmed-buffer)))
(loop for ch across encoded-string
do (progn
(write-char ch sock)
(incf column-count)
(when (= column-count wrap-at-column)
(setq column-count 0)
(write-char #\Newline sock))))))
(force-output sock)
(print-debug (format nil "~% Eof is ~a~%" eof?))
(when (or (zerop buffer-size)
eof?)
(return))))))))
......@@ -29,7 +29,10 @@
(print ,str)))
(asdf:defsystem :cl-smtp
:version "20071018.1"
:version "20071104.1"
:perform (load-op :after (op webpage)
(pushnew :cl-smtp cl:*features*))
:depends-on (:usocket #-allegro :cl-base64)
:components ((:file "cl-smtp" :depends-on ("attachments"))
(:file "attachments")))
(:file "attachments")
(:file "mime-types")))
......@@ -18,6 +18,8 @@
(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)))
......@@ -61,12 +63,13 @@
(defun send-email (host from to subject message
&key (port 25) cc bcc reply-to extra-headers
display-name authentication
html-message display-name authentication
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
:extra-headers extra-headers
:html-message html-message
:display-name display-name
:authentication authentication
:attachments (check-arg attachments "attachments")
......@@ -76,56 +79,64 @@
(defun send-smtp (host from to subject message
&key (port 25) cc bcc reply-to extra-headers
&key (port 25) cc bcc reply-to extra-headers html-message
display-name authentication attachments buffer-size)
(let ((sock (usocket:socket-stream (usocket:socket-connect host port)))
(boundary (make-random-boundary)))
(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)
(write-to-smtp sock
(format nil "MAIL FROM:~@[~A ~]<~A>" display-name from))
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(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")
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(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))
(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*))
(when reply-to
(write-to-smtp sock (format nil "Reply-To: ~A" reply-to)))
(when (and extra-headers
(listp extra-headers))
(dolist (l extra-headers)
(write-to-smtp sock
(format nil "~A: ~{~a~^,~}" (car l) (rest l)))))
(write-to-smtp sock "Mime-Version: 1.0")
(when attachments
(generate-multipart-header sock boundary))
(write-char #\Return sock)
(write-char #\NewLine sock)
(when attachments
(setq message (wrap-message-with-multipart-dividers
message boundary)))
(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)
(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-attachments-end-marker sock boundary))
(send-end-marker sock boundary))
(write-char #\. sock)
(write-char #\Return sock)
(write-char #\NewLine sock)
......@@ -190,6 +201,49 @@
(when (/= code 250)
(error "wrong response from smtp server: ~A" msgstr))))))
(defun send-smtp-headers (sock
&key from to cc bcc reply-to
extra-headers display-name subject)
(write-to-smtp sock
(format nil "MAIL FROM:~@[~A ~]<~A>" display-name from))
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(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")
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(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))
(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*))
(when reply-to
(write-to-smtp sock (format nil "Reply-To: ~A" reply-to)))
(when (and extra-headers
(listp extra-headers))
(dolist (l extra-headers)
(write-to-smtp sock
(format nil "~A: ~{~a~^,~}" (car l) (rest l)))))
(write-to-smtp sock "Mime-Version: 1.0"))
(defun send-multipart-headers (sock &key attachment-boundary html-boundary)
(cond (attachment-boundary
(generate-multipart-header sock attachment-boundary
:multipart-type "mixed"))
(html-boundary (generate-multipart-header
sock html-boundary
:multipart-type "alternative"))
(t nil)))
(defun compute-rcpt-command (sock adresses)
(dolist (to adresses)
......@@ -198,7 +252,6 @@
(read-from-smtp sock)
(when (/= code 250)
(error "in RCPT TO command: ~A" msgstr)))))
(defun write-to-smtp (sock command)
(print-debug (format nil "to server: ~A" command))
......@@ -207,6 +260,11 @@
(write-char #\NewLine sock)
(force-output sock))
(defun write-blank-line (sock)
(write-char #\Return sock)
(write-char #\NewLine sock)
(force-output sock))
(defun read-from-smtp (sock)
(let* ((line (read-line sock))
(response-code (parse-integer line :start 0 :junk-allowed t)))
......@@ -214,7 +272,7 @@
(if (= (char-code (elt line 3)) (char-code #\-))
(read-from-smtp sock)
(values response-code line))))
(defun get-email-date-string ()
(multiple-value-bind (sec min h d m y wd) (get-decoded-time)
(let* ((month (elt '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (- m 1)))
......@@ -224,8 +282,7 @@
(get-universal-time)))))
(format nil "~A, ~2,'0d ~A ~d ~2,'0d:~2,'0d:~2,'0d ~D"
weekday d month y h min sec timezone))))
(defun get-timezone-from-integer (x)
(let ((min (/ x 60))
(hour (/ x 3600)))
......
This diff is collapsed.
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