From jdzerins at common-lisp.net Tue Apr 5 08:45:43 2005 From: jdzerins at common-lisp.net (Janis Dzerins) Date: Tue, 5 Apr 2005 10:45:43 +0200 (CEST) Subject: [rfc2388-cvs] CVS update: rfc2388/packages.lisp rfc2388/rfc2388.asd rfc2388/rfc2388.lisp Message-ID: <20050405084543.9E6FC880E1@common-lisp.net> Update of /project/rfc2388/cvsroot/rfc2388 In directory common-lisp.net:/tmp/cvs-serv14557 Modified Files: rfc2388.lisp Added Files: packages.lisp rfc2388.asd Log Message: Incorporated changes from UCW fork. Date: Tue Apr 5 10:45:25 2005 Author: jdzerins Index: rfc2388/rfc2388.lisp diff -u rfc2388/rfc2388.lisp:1.3 rfc2388/rfc2388.lisp:1.4 --- rfc2388/rfc2388.lisp:1.3 Sun Jun 13 01:12:46 2004 +++ rfc2388/rfc2388.lisp Tue Apr 5 10:45:21 2005 @@ -1,5 +1,4 @@ -;;; -*- mode: LISP; package: RFC2388 -*- - +;;;; -*- mode: LISP; package: RFC2388 -*- ;;;; Copyright (c) 2003 Janis Dzerins ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -21,49 +20,25 @@ ;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -(defpackage :rfc2388 - (:use :common-lisp) - (:export - ;;#:read-until-next-boundary - - #:parse-header - #:header - #:header-name - #:header-value - #:header-parameters - - #:parse-mime - #:mime-part - #:mime-part-contents - #:mime-part-headers)) - - (in-package :rfc2388) - - (defun lwsp-char-p (char) "Returns true if CHAR is a linear-whitespace-char (LWSP-char). Either space or tab, in short." (or (char= char #\space) (char= char #\tab))) - - - ;;; *** This actually belongs to RFC2046 ;;; (defun read-until-next-boundary (stream boundary &optional discard) "Reads from STREAM up to the next boundary. Returns two values: read data (nil if DISCARD is true), and true if the boundary is not last (i.e., there's more data)." - ;; Read until [CRLF]--boundary[--][transport-padding]CRLF ;; States: 1 2 345 67 8 9 10 ;; ;; *** This will WARN like crazy on some bad input -- should only do each ;; warning once. - (let ((length (length boundary))) (unless (<= 1 length 70) (warn "Boundary has invalid length -- must be between 1 and 70, but is: ~S" length)) @@ -209,11 +184,8 @@ (values (get-output-stream-string stream) closed))))) - - -;;; Header parsing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; - +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Header parsing (defstruct (header (:type list) (:constructor make-header (name value parameters))) @@ -221,22 +193,21 @@ value parameters) - - (defun skip-linear-whitespace (string &key (start 0) end) "Returns the position of first non-linear-whitespace character in STRING bound by START and END." (position-if-not #'lwsp-char-p string :start start :end end)) +(defgeneric parse-header (source &optional start-state) + (:documentation "Parses SOURCE and returs a single MIME header. +Header is a list of the form (NAME VALUE PARAMETERS), PARAMETERS +is a list of (NAME . VALUE)")) (defmethod parse-header ((source string) &optional (start-state :name)) (with-input-from-string (in source) (parse-header in start-state))) - - - ;;; *** I don't like this parser -- it will have to be rewritten when I ;;; make my state-machine parser-generator macro! ;;; @@ -250,7 +221,6 @@ (result (make-string-output-stream)) char (leave-char nil) - name value parameter-name @@ -369,38 +339,27 @@ nil (make-header name value parameters)))) - - (defgeneric parse-mime (source boundary) (:documentation "Parses MIME entities, returning them as a list. Each element in the - list is of form: (body . header*), where BODY is the contents of MIME + list is of form: (body headers), where BODY is the contents of MIME part, and HEADERS are all headers for that part. BOUNDARY is a string used to separate MIME entities.")) - - (defstruct (mime-part (:type list) (:constructor make-mime-part (contents headers))) contents headers) - - (defmethod parse-mime ((input string) separator) (with-input-from-string (stream input) (parse-mime stream separator))) - - - (defmethod parse-mime ((input stream) boundary) - ;; Find the first boundary. Return immediately if it is also the last ;; one. (unless (nth-value 1 (read-until-next-boundary input boundary t)) (return-from parse-mime nil)) - (let ((result ())) (loop (let ((headers (loop @@ -413,4 +372,3 @@ (when (not more) (return))))) (nreverse result))) - From jdzerins at common-lisp.net Tue Apr 5 09:25:28 2005 From: jdzerins at common-lisp.net (Janis Dzerins) Date: Tue, 5 Apr 2005 11:25:28 +0200 (CEST) Subject: [rfc2388-cvs] CVS update: rfc2388/packages.lisp rfc2388/rfc2388.lisp Message-ID: <20050405092528.DBFC1880E1@common-lisp.net> Update of /project/rfc2388/cvsroot/rfc2388 In directory common-lisp.net:/tmp/cvs-serv17091 Modified Files: packages.lisp rfc2388.lisp Log Message: Incorporated changes from TBNL fork. Date: Tue Apr 5 11:25:28 2005 Author: jdzerins Index: rfc2388/packages.lisp diff -u rfc2388/packages.lisp:1.1 rfc2388/packages.lisp:1.2 --- rfc2388/packages.lisp:1.1 Tue Apr 5 10:45:21 2005 +++ rfc2388/packages.lisp Tue Apr 5 11:25:27 2005 @@ -23,15 +23,20 @@ (defpackage :rfc2388 (:use :common-lisp) (:export - ;;#:read-until-next-boundary - #:parse-header #:header #:header-name #:header-value #:header-parameters + #:content-type + #:find-header + #:find-parameter + #:find-content-disposition-header + #:get-file-name + #:parse-mime #:mime-part #:mime-part-contents - #:mime-part-headers)) + #:mime-part-headers + #:make-mime-part)) Index: rfc2388/rfc2388.lisp diff -u rfc2388/rfc2388.lisp:1.4 rfc2388/rfc2388.lisp:1.5 --- rfc2388/rfc2388.lisp:1.4 Tue Apr 5 10:45:21 2005 +++ rfc2388/rfc2388.lisp Tue Apr 5 11:25:27 2005 @@ -1,5 +1,6 @@ ;;;; -*- mode: LISP; package: RFC2388 -*- ;;;; Copyright (c) 2003 Janis Dzerins +;;;; Modifications for TBNL Copyright (c) 2004 Michael Weber and Dr. Edmund Weitz ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions @@ -22,15 +23,21 @@ (in-package :rfc2388) + + +;;; Utility functions + + (defun lwsp-char-p (char) "Returns true if CHAR is a linear-whitespace-char (LWSP-char). Either space or tab, in short." (or (char= char #\space) (char= char #\tab))) + ;;; *** This actually belongs to RFC2046 ;;; -(defun read-until-next-boundary (stream boundary &optional discard) +(defun read-until-next-boundary (stream boundary &optional discard out-stream) "Reads from STREAM up to the next boundary. Returns two values: read data (nil if DISCARD is true), and true if the boundary is not last (i.e., there's more data)." @@ -39,6 +46,7 @@ ;; ;; *** This will WARN like crazy on some bad input -- should only do each ;; warning once. + (let ((length (length boundary))) (unless (<= 1 length 70) (warn "Boundary has invalid length -- must be between 1 and 70, but is: ~S" length)) @@ -179,13 +187,21 @@ (if discard (let ((stream (make-broadcast-stream))) (values nil (run stream))) - (let* ((stream (make-string-output-stream)) + (let* ((stream (or out-stream (make-string-output-stream))) (closed (run stream))) - (values (get-output-stream-string stream) + (values (or out-stream (get-output-stream-string stream)) closed))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Header parsing + +(defun make-tmp-file-name () + (if (find-package :tbnl) + (funcall (find-symbol "MAKE-TMP-FILE-NAME" :tbnl)) + (error "WRITE-CONTENT-TO-FILE keyword argument to PARSE-MIME is supported in TBNL only at the moment."))) + + + +;;; Header parsing + (defstruct (header (:type list) (:constructor make-header (name value parameters))) @@ -193,21 +209,25 @@ value parameters) + (defun skip-linear-whitespace (string &key (start 0) end) "Returns the position of first non-linear-whitespace character in STRING bound by START and END." (position-if-not #'lwsp-char-p string :start start :end end)) + (defgeneric parse-header (source &optional start-state) (:documentation "Parses SOURCE and returs a single MIME header. Header is a list of the form (NAME VALUE PARAMETERS), PARAMETERS is a list of (NAME . VALUE)")) + (defmethod parse-header ((source string) &optional (start-state :name)) (with-input-from-string (in source) (parse-header in start-state))) + ;;; *** I don't like this parser -- it will have to be rewritten when I ;;; make my state-machine parser-generator macro! ;;; @@ -266,7 +286,7 @@ (setq leave-char t)))) #-(and) - (format t "~&S:~D,'0D CH:~:[~;*~]~S~%" + (format t "~&S:~,'0D CH:~:[~;*~]~S~%" state leave-char char) (ecase state @@ -339,36 +359,137 @@ nil (make-header name value parameters)))) -(defgeneric parse-mime (source boundary) + + +;;; _The_ MIME parsing + + +(defgeneric parse-mime (source boundary &key recursive-p write-content-to-file) (:documentation "Parses MIME entities, returning them as a list. Each element in the list is of form: (body headers), where BODY is the contents of MIME part, and HEADERS are all headers for that part. BOUNDARY is a string used to separate MIME entities.")) + +(defstruct (content-type (:type list) + (:constructor make-content-type (super sub))) + super + sub) + + +(defun parse-content-type (string) + "Returns content-type which is parsed from STRING." + (let ((sep-offset (position #\/ string)) + (type (array-element-type string))) + (if (numberp sep-offset) + (make-content-type (make-array sep-offset + :element-type type + :displaced-to string) + (make-array (- (length string) (incf sep-offset)) + :element-type type + :displaced-to string + :displaced-index-offset sep-offset)) + (make-content-type string nil)))) + + +(defun unparse-content-type (ct) + "Returns content-type CT in string representation." + (let ((super (content-type-super ct)) + (sub (content-type-sub ct))) + (cond ((and super sub) + (concatenate 'string super "/" sub)) + (t (or super ""))))) + (defstruct (mime-part (:type list) (:constructor make-mime-part (contents headers))) contents headers) -(defmethod parse-mime ((input string) separator) + +(defmethod parse-mime ((input string) separator &key (recursive-p t) (write-content-to-file t)) (with-input-from-string (stream input) - (parse-mime stream separator))) + (parse-mime stream separator :recursive-p recursive-p :write-content-to-file write-content-to-file))) + -(defmethod parse-mime ((input stream) boundary) +(defmethod parse-mime ((input stream) boundary &key (recursive-p t) (write-content-to-file t)) ;; Find the first boundary. Return immediately if it is also the last ;; one. (unless (nth-value 1 (read-until-next-boundary input boundary t)) (return-from parse-mime nil)) - (let ((result ())) + + (let ((result ()) + content-type-header) (loop (let ((headers (loop - for header = (parse-header input) - while header - collect header))) - (multiple-value-bind (text more) - (read-until-next-boundary input boundary) - (push (make-mime-part text headers) result) - (when (not more) - (return))))) + for header = (parse-header input) + while header + when (string-equal "CONTENT-TYPE" (header-name header)) + do (setf content-type-header header + (header-value header) (parse-content-type (header-value header))) + collect header))) + (if (and recursive-p + (string-equal "MULTIPART" (content-type-super (header-value content-type-header)))) + (let ((boundary (cdr (find-parameter "BOUNDARY" (header-parameters content-type-header))))) + (push (make-mime-part (parse-mime input boundary) headers) result)) + (let ((file-name (get-file-name headers))) + (cond ((and write-content-to-file + file-name) + (let ((temp-file (make-tmp-file-name))) + (multiple-value-bind (text more) + (with-open-file (out-file (ensure-directories-exist temp-file) + :direction :output + ;; external format for faithful I/O + ;; see + #+(or :lispworks :allegro) + :external-format + #+:lispworks '(:latin-1 :eol-style :lf) + #+:allegro (excl:crlf-base-ef :latin1)) + (read-until-next-boundary input boundary nil out-file)) + (declare (ignore text)) + (when (and (stringp file-name) + (plusp (length file-name))) + (push (make-mime-part temp-file headers) result)) + (when (not more) + (return))))) + (t + (multiple-value-bind (text more) + (read-until-next-boundary input boundary) + (push (make-mime-part text headers) result) + (when (not more) + (return))))))))) (nreverse result))) + + +(defun find-header (label headers) + "Find header by label from set of headers." + (find label headers :key #'rfc2388:header-name :test #'string-equal)) + + +(defun find-parameter (name params) + "Find header parameter by name from set of parameters." + (assoc name params :test #'string-equal)) + + +(defun content-type (part &key as-string) + "Returns the Content-Type header of mime-part PART." + (let ((header (find-header "CONTENT-TYPE" (mime-part-headers part)))) + (if header + (if as-string + (or (unparse-content-type (header-value header)) "") + (header-value header)) + (when as-string "")))) + + +(defun find-content-disposition-header (headers) + (find-if (lambda (header) + (and (string-equal "CONTENT-DISPOSITION" + (rfc2388:header-name header)) + (string-equal "FORM-DATA" + (rfc2388:header-value header)))) + headers)) + + +(defun get-file-name (headers) + (cdr (find-parameter "FILENAME" + (header-parameters (find-content-disposition-header headers))))) From jdzerins at common-lisp.net Tue Apr 5 12:02:27 2005 From: jdzerins at common-lisp.net (Janis Dzerins) Date: Tue, 5 Apr 2005 14:02:27 +0200 (CEST) Subject: [rfc2388-cvs] CVS update: Directory change: rfc2388/debian Message-ID: <20050405120227.05D0088665@common-lisp.net> Update of /project/rfc2388/cvsroot/rfc2388/debian In directory common-lisp.net:/tmp/cvs-serv27119/debian Log Message: Directory /project/rfc2388/cvsroot/rfc2388/debian added to the repository Date: Tue Apr 5 14:02:25 2005 Author: jdzerins New directory rfc2388/debian added From jdzerins at common-lisp.net Tue Apr 5 12:04:08 2005 From: jdzerins at common-lisp.net (Janis Dzerins) Date: Tue, 5 Apr 2005 14:04:08 +0200 (CEST) Subject: [rfc2388-cvs] CVS update: rfc2388/debian/changelog rfc2388/debian/control rfc2388/debian/copyright rfc2388/debian/postinst rfc2388/debian/prerm rfc2388/debian/rules Message-ID: <20050405120408.E438788665@common-lisp.net> Update of /project/rfc2388/cvsroot/rfc2388/debian In directory common-lisp.net:/tmp/cvs-serv27143/debian Added Files: changelog control copyright postinst prerm rules Log Message: Added debian control directory. Date: Tue Apr 5 14:04:06 2005 Author: jdzerins From jdzerins at common-lisp.net Mon Apr 18 12:23:26 2005 From: jdzerins at common-lisp.net (Janis Dzerins) Date: Mon, 18 Apr 2005 14:23:26 +0200 (CEST) Subject: [rfc2388-cvs] CVS update: rfc2388/packages.lisp Message-ID: <20050418122326.49930880E1@common-lisp.net> Update of /project/rfc2388/cvsroot/rfc2388 In directory common-lisp.net:/tmp/cvs-serv31357 Modified Files: packages.lisp Log Message: Added IN-PACKAGE form. Date: Mon Apr 18 14:23:25 2005 Author: jdzerins Index: rfc2388/packages.lisp diff -u rfc2388/packages.lisp:1.2 rfc2388/packages.lisp:1.3 --- rfc2388/packages.lisp:1.2 Tue Apr 5 11:25:27 2005 +++ rfc2388/packages.lisp Mon Apr 18 14:23:25 2005 @@ -20,6 +20,8 @@ ;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +(in-package :cl-user) + (defpackage :rfc2388 (:use :common-lisp) (:export