diff -x '*.fasl' -Nur tbnl-0.2.12.orig/packages.lisp tbnl-0.2.12/packages.lisp --- tbnl-0.2.12.orig/packages.lisp 2004-10-15 23:45:27.000000000 +0200 +++ tbnl-0.2.12/packages.lisp 2004-10-27 16:24:58.000000000 +0200 @@ -141,7 +141,9 @@ #:no-cache #:parameter #:post-parameter + #:post-parameter* #:post-parameters + #:post-parameters* #:query-string #:read-from-string* #:real-remote-addr diff -x '*.fasl' -Nur tbnl-0.2.12.orig/request.lisp tbnl-0.2.12/request.lisp --- tbnl-0.2.12.orig/request.lisp 2004-07-24 02:56:02.000000000 +0200 +++ tbnl-0.2.12/request.lisp 2004-10-27 16:34:47.000000000 +0200 @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: TBNL; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/tbnl/request.lisp,v 1.12 2004/07/24 00:56:02 edi Exp $ +;;; $Header: /home/michaelw/.sbcl/site/tbnl-0.2.12/RCS/request.lisp,v 1.1 2004/10/26 09:48:16 michaelw Exp michaelw $ ;;; Copyright (c) 2004, Dr. Edmund Weitz. All rights reserved. @@ -40,7 +40,7 @@ :documentation "An alist of the GET parameters sent by the client.") (post-parameters :initform nil - :documentation "An alist of the POST parameters + :documentation "A hash-table of the POST parameters sent by the client.") (script-name :initform nil :documentation "The URI requested by the client without @@ -79,12 +79,17 @@ (t (setq script-name uri)))) ;; if the content-type is 'application/x-www-form-urlencoded' ;; compute the post parameters from the content body - (when (string-equal "application/x-www-form-urlencoded" - (string-assoc "content-type" headers-in)) - (setq post-parameters - (form-url-encoded-list-to-alist - (cl-ppcre:split "&" - (string-assoc "posted-content" headers-in))))) + (let ((content-type (string-assoc "content-type" headers-in))) + (setq post-parameters (make-hash-table :test #'equal)) + (cond ((string-equal "application/x-www-form-urlencoded" content-type) + (form-url-encoded-list-to-hashtable + (cl-ppcre:split "&" + (string-assoc "posted-content" headers-in)) + post-parameters)) + ((string-prefixp "multipart/form-data;" content-type) + (parse-rfc2388-form-data (string-assoc "posted-content" headers-in) + :header content-type + :hash post-parameters)))) ;; compute GET parameters from query string and cookies from the ;; incoming 'Cookie' header (setq get-parameters @@ -117,6 +122,12 @@ (defun post-parameters (&optional (request *request*)) "Returns an alist of the POST parameters associated with the REQUEST object REQUEST." + (hashtable-alist (slot-value request 'post-parameters) + :value-accessor (lambda (vs) (rfc2388:mime-part-contents (first vs))))) + +(defun post-parameters* (&optional (request *request*)) + "Returns a hashtable of the POST parameters associated with the +REQUEST object REQUEST." (slot-value request 'post-parameters)) (defun headers-in (&optional (request *request*)) @@ -251,7 +262,13 @@ (defun post-parameter (name &optional (request *request*)) "Returns the POST parameter with name NAME as captured in the REQUEST object REQUEST. Search is case-sensitive." - (string-assoc* name (post-parameters request))) + #-(or) (string-assoc* name (post-parameters request)) + (rfc2388:mime-part-contents (first (gethash name (post-parameters* request))))) + +(defun post-parameter* (name &optional (request *request*)) + "Returns the collated list of POST parameters with name NAME as captured +in the REQUEST object REQUEST. Search is case-sensitive." + (gethash name (post-parameters* request))) (declaim (inline parameter)) (defun parameter (name &optional (request *request*)) diff -x '*.fasl' -Nur tbnl-0.2.12.orig/rfc2388.lisp tbnl-0.2.12/rfc2388.lisp --- tbnl-0.2.12.orig/rfc2388.lisp 1970-01-01 01:00:00.000000000 +0100 +++ tbnl-0.2.12/rfc2388.lisp 2004-10-27 21:06:13.000000000 +0200 @@ -0,0 +1,466 @@ +;;; -*- mode: LISP; package: RFC2388 -*- + +;;;; Copyright (c) 2003 Janis Dzerins +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +;;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (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 + + #:content-type + #:find-header + #:find-parameter + + #:parse-mime + #:mime-part + #:mime-part-contents + #:mime-part-headers + #:make-mime-part)) + + +(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)) + (let ((last-char (schar boundary (1- length)))) + (when (or (char= last-char #\space) + (char= last-char #\tab)) + (warn "Boundary has trailing whitespace: ~S" boundary)))) + + (flet ((run (result) + "This one writes everything up to a boundary to RESULT stream, + and returns false if the closing delimiter has been read, and + true otherwise." + (let ((state 1) + (boundary-index 0) + (boundary-length (length boundary)) + (closed nil) + (queued-chars (make-string 4)) + (queue-index 0) + char + (leave-char nil)) + + (flet ((write-queued-chars () + (dotimes (i queue-index) + (write-char (schar queued-chars i) result)) + (setf queue-index 0)) + + (enqueue-char () + (setf (schar queued-chars queue-index) char) + (incf queue-index))) + + (loop + + (if leave-char + (setq leave-char nil) + (setq char (read-char stream nil nil))) + + (unless char + (setq closed t) + (return)) + + #-(and) + (format t "~&S:~D BI:~2,'0D CH:~:[~;*~]~S~%" + state boundary-index leave-char char) + + (case state + (1 ;; optional starting CR + (cond ((char= char #\return) + (enqueue-char) + (setq state 2)) + ((char= char #\-) + (setq leave-char t + state 3)) + (t + (write-char char result)))) + + (2 ;; optional starting LF + (cond ((char= char #\linefeed) + (enqueue-char) + (setq state 3)) + (t + (write-queued-chars) + (write-char char result) + (setq state 1)))) + + (3 ;; first dash in dash-boundary + (cond ((char= char #\-) + (enqueue-char) + (setq state 4)) + (t + (write-queued-chars) + (write-char char result) + (setq state 1)))) + + (4 ;; second dash in dash-boundary + (cond ((char= char #\-) + (enqueue-char) + (setq state 5)) + (t + (write-queued-chars) + (write-char char result) + (setq state 1)))) + + (5 ;; boundary + (cond ((char= char (schar boundary boundary-index)) + (incf boundary-index) + (when (= boundary-index boundary-length) + (setq state 6))) + (t + (write-queued-chars) + (write-sequence boundary result :end boundary-index) + (write-char char result) + (setq boundary-index 0 + state 1)))) + + (6 ;; first dash in close-delimiter + (cond ((char= char #\-) + (setq state 7)) + (t + (setq leave-char t) + (setq state 8)))) + + (7 ;; second dash in close-delimiter + (cond ((char= char #\-) + (setq closed t + state 8)) + (t + ;; this is a strange situation -- only two dashes, linear + ;; whitespace or CR is allowed after boundary, but there was + ;; a single dash... One thing is clear -- this is not a + ;; close-delimiter. Hence this is garbage what we're looking + ;; at! + (warn "Garbage where expecting close-delimiter!") + (setq leave-char t) + (setq state 8)))) + + (8 ;; transport-padding (LWSP* == [#\space #\tab]*) + (cond ((lwsp-char-p char) + ;; ignore these + ) + (t + (setq leave-char t) + (setq state 9)))) + + (9 ;; CR + (cond ((char= char #\return) + (setq state 10)) + (t + (warn "Garbage where expecting CR!")))) + + (10 ;; LF + (cond ((char= char #\linefeed) + ;; the end + (return)) + (t + (warn "Garbage where expecting LF!"))))))) + (not closed)))) + + (if discard + (let ((stream (make-broadcast-stream))) + (values nil (run stream))) + (let* ((stream (make-string-output-stream)) + (closed (run stream))) + (values (get-output-stream-string stream) + closed))))) + + + +;;; Header parsing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + + +(defstruct (header (:type list) + (:constructor make-header (name value parameters))) + name + 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)) + + + +(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! +;;; +(defmethod parse-header ((stream stream) &optional (start-state :name)) + "Returns a MIME part header, or NIL, if there is no header. Header is + terminated by CRLF." + (let ((state (ecase start-state + (:name 1) + (:value 2) + (:parameters 3))) + (result (make-string-output-stream)) + char + (leave-char nil) + + name + value + parameter-name + parameters) + + (labels ((skip-lwsp (next-state) + (loop + do (setq char (read-char stream nil nil)) + while (and char (lwsp-char-p char))) + (setq leave-char t + state next-state)) + + (collect-parameter () + (push (cons parameter-name + (get-output-stream-string result)) + parameters) + (setq parameter-name nil) + (skip-lwsp 3)) + + (token-end-char-p (char) + (or (char= char #\;) + (lwsp-char-p char)))) + + (loop + + (if leave-char + (setq leave-char nil) + (setq char (read-char stream nil nil))) + + ;; end of stream + (unless char + (return)) + + (when (char= #\return char) + (setq char (read-char stream nil nil)) + (cond ((or (null char) + (char= #\linefeed char)) + ;; CRLF ends the input + (return)) + (t + (warn "LINEFEED without RETURN in header.") + (write-char #\return result) + (setq leave-char t)))) + + #-(and) + (format t "~&S:~,'0D CH:~:[~;*~]~S~%" + state leave-char char) + + (ecase state + (1 ;; NAME + (cond ((char= char #\:) + ;; end of name + (setq name (get-output-stream-string result)) + (skip-lwsp 2)) + (t + (write-char char result)))) + + (2 ;; VALUE + (cond ((token-end-char-p char) + (setq value (get-output-stream-string result)) + (skip-lwsp 3)) + (t + (write-char char result)))) + + (3 ;; PARAMETER name + (cond ((char= #\= char) + (setq parameter-name (get-output-stream-string result) + state 4)) + (t + (write-char char result)))) + + (4 ;; PARAMETER value start + (cond ((char= #\" char) + (setq state 5)) + (t + (setq leave-char t + state 7)))) + + (5 ;; Quoted PARAMETER value + (cond ((char= #\" char) + (setq state 6)) + (t + (write-char char result)))) + + (6 ;; End of quoted PARAMETER value + (cond ((token-end-char-p char) + (collect-parameter)) + (t + ;; no space or semicolon after quoted parameter value + (setq leave-char t + state 3)))) + + (7 ;; Unquoted PARAMETER value + (cond ((token-end-char-p char) + (collect-parameter)) + (t + (write-char char result)))))) + + (case state + (1 + (setq name (get-output-stream-string result))) + (2 + (setq value (get-output-stream-string result))) + ((3 4) + (let ((name (get-output-stream-string result))) + (unless (zerop (length name)) + (warn "Parameter without value in header.") + (push (cons name nil) parameters)))) + ((5 6 7) + (push (cons parameter-name (get-output-stream-string result)) parameters)))) + + (if (and (or (null name) + (zerop (length name))) + (null value) + (null parameters)) + nil + (make-header name value parameters)))) + + + +(defgeneric parse-mime (source boundary &key recursive-p) + (: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 + 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 &key (recursive-p t)) + (with-input-from-string (stream input) + (parse-mime stream separator :recursive-p recursive-p))) + +(defmethod parse-mime ((input stream) boundary &key (recursive-p 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 ()) + content-type-header) + (loop + (let ((headers (loop + 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)) + (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 "")))) diff -x '*.fasl' -Nur tbnl-0.2.12.orig/tbnl.asd tbnl-0.2.12/tbnl.asd --- tbnl-0.2.12.orig/tbnl.asd 2004-07-24 02:02:54.000000000 +0200 +++ tbnl-0.2.12/tbnl.asd 2004-10-27 21:04:50.000000000 +0200 @@ -37,11 +37,12 @@ (defsystem tbnl :depends-on (#:md5 #:cl-base64 #:cl-ppcre #:kmrcl #:url-rewrite) :components ((:file "packages") + (:file "rfc2388") (:file "specials" :depends-on ("packages")) - (:file "util" :depends-on ("specials")) + (:file "util" :depends-on ("specials" "rfc2388")) (:file "log" :depends-on ("util")) (:file "cookie" :depends-on ("util")) - (:file "request" :depends-on ("util" "reply" "specials")) + (:file "request" :depends-on ("util" "reply" "specials" "rfc2388")) (:file "reply" :depends-on ("util")) (:file "session" :depends-on ("cookie" "log")) (:file "html" :depends-on ("session" "request" "util")) diff -x '*.fasl' -Nur tbnl-0.2.12.orig/test/test.lisp tbnl-0.2.12/test/test.lisp --- tbnl-0.2.12.orig/test/test.lisp 2004-08-28 21:37:52.000000000 +0200 +++ tbnl-0.2.12/test/test.lisp 2004-10-27 22:43:41.000000000 +0200 @@ -113,6 +113,14 @@ "image/jpeg") *test-image*) +(defparameter *uploaded-file* nil) + +(defun uploaded-file-page () + (let ((file (or *uploaded-file* + (rfc2388:make-mime-part "None so far." '())))) + (setf (content-type) (rfc2388:content-type file :as-string t)) + (rfc2388:mime-part-contents file))) + (let ((count 0)) (defun info () (with-html @@ -184,6 +192,9 @@ (let ((new-bar-value (post-parameter "new-bar-value"))) (when new-bar-value (setf (session-value 'bar) new-bar-value))) + (let ((new-file-value (post-parameter* "new-file-value"))) + (when new-file-value + (setf *uploaded-file* (first new-file-value)))) (with-html (:html (:head (:title "TBNL Session Test")) @@ -197,13 +208,20 @@ ". You can later return to this page to check if they're still set. Also, try to use another browser at the same time or try with cookies disabled.") - (:p (:form :method :post + (:p (:a :href "/tbnl/test/uploaded-file" "Last uploaded file")) + (:p (:form :method :post :enctype "multipart/form-data" "New value for " (:code "FOO") ": " (:input :type :text :name "new-foo-value" - :value (or (session-value 'foo) "")))) + :value (or (session-value 'foo) "")) + " " + (:input :type :file + :name "new-file-value") + " " + (:input :type :submit + :value "Upload"))) (:p (:form :method :post "New value for " (:code "BAR") @@ -215,7 +233,10 @@ (cookie-in *session-cookie-name*) (mapcar #'car (cookies-in)) (session-value 'foo) - (session-value 'bar)))))) + (session-value 'bar) + (header-in "Content-Type") + (post-parameters) + (tbnl::hashtable-alist (post-parameters*))))))) (defparameter *headline* (load-time-value @@ -280,6 +301,7 @@ ("/tbnl/test/info.html" info) ("/tbnl/test/authorization.html" authorization-page) ("/tbnl/test/image-ram.jpg" image-ram-page) + ("/tbnl/test/uploaded-file" uploaded-file-page) ("/tbnl/test/cookie.html" cookie-test) ("/tbnl/test/session.html" session-test) ("/tbnl/test/redir.html" redir) diff -x '*.fasl' -Nur tbnl-0.2.12.orig/util.lisp tbnl-0.2.12/util.lisp --- tbnl-0.2.12.orig/util.lisp 2004-09-02 06:43:17.000000000 +0200 +++ tbnl-0.2.12/util.lisp 2004-10-27 20:24:28.000000000 +0200 @@ -144,6 +144,18 @@ (url-decode (or value ""))))) form-url-encoded-list)) +(defun form-url-encoded-list-to-hashtable (form-url-encoded-list + &optional (hash (make-hash-table :test #'equal))) + "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into a hash-table. +Both names andvalues are url-decoded while doing this." + (mapc #'(lambda (entry) + (destructuring-bind (name &optional value) + (cl-ppcre:split "=" entry :limit 2) + (push (rfc2388:make-mime-part (url-decode (or value "")) ()) + (gethash (string-trim " " (url-decode name)) hash)))) + form-url-encoded-list) + hash) + (defun md5-hex (string) "Calculates the md5 sum of the string STRING and returns it as a hex string." (with-output-to-string (s) @@ -260,3 +272,33 @@ (declare (ignore error)) (format nil "Output of backtrace currently not implemented for ~A" (lisp-implementation-type))) + +(define-modify-macro nconcf (&rest args) + nconc "nconc onto list") + +(defun hashtable-alist (ht &key (value-accessor #'identity)) + (loop :for key :being :each :hash-key :in ht + :using (hash-value value) + :collect (cons key (funcall value-accessor value)))) + +(defun string-prefixp (prefix s &key (test #'string-equal)) + (funcall test prefix s :end2 (min (length prefix) (length s)))) + +(defun parse-rfc2388-form-data (str &key header (hash (make-hash-table :test #'equal))) + (let* ((header (if (stringp header) + (rfc2388:parse-header header :value) + (rfc2388:parse-header str))) + (params hash) + (boundary (or (cdr (rfc2388:find-parameter "BOUNDARY" (rfc2388:header-parameters header))) + (return-from parse-rfc2388-form-data params))) + (form-data (rfc2388:parse-mime str boundary))) + (dolist (part form-data) + (let* ((header (find-if (lambda (h) + (and (string-equal "CONTENT-DISPOSITION" + (rfc2388:header-name h)) + (string-equal "FORM-DATA" + (rfc2388:header-value h)))) + (rfc2388:mime-part-headers part))) + (name (cdr (rfc2388:find-parameter "NAME" (rfc2388:header-parameters header))))) + (when name (nconcf (gethash name params) (list part))))) + params))