From edi at agharta.de Fri Oct 15 21:51:41 2004 From: edi at agharta.de (Edi Weitz) Date: Fri, 15 Oct 2004 23:51:41 +0200 Subject: [tbnl-devel] New version 0.2.12 Message-ID: Just a minor addition: Version 0.2.12 2004-10-15 Exported and documented DO-SESSIONS Release is at Cheers, Edi. From michaelw+tbnl at foldr.org Wed Oct 27 21:04:17 2004 From: michaelw+tbnl at foldr.org (Michael Weber) Date: Wed, 27 Oct 2004 23:04:17 +0200 Subject: [tbnl-devel] multipart/form-data forms, RFC2388, File Uploads Message-ID: <20041027210417.GA2668@roadkill.foldr.org> Hi, Attached is a patch with my stab at file upload capabilities for TBNL. :) [To my defense, I first played around with rfc2388. Then I switched to TBNL and found it to be rather straight-forward to add this functionality. Only afterwards I found out about the efforts of others regarding file uploads for TBNL.] Anyway, here's what the patch is about: * Adds support for multipart/form-data forms. * Can parse rfc2388 MIME data. * Enables file upload. * Introduces POST-PARAMETER* and POST-PARAMETERS* to give richer information about posted data (MIME headers). Also, the starred versions collate parameters with equal name into a list. + If successful, POST-PARAMETER* returns a list of MIME-PARTs, each of which can be further poked at with accessors exported from RFC2388. + POST-PARAMETERS* returns the corresponding hash-table. * Is backwards compatible with original TBNL, although the old interface is less efficiently implemented now (conses more). * Uses a slightly patched rfc2388.lisp (http://common-lisp.net/project/rfc2388) by Janis Dzerins, which is included completely in the patch. * Adds a file upload example to test/test.lisp (sessions.html). It is not very polished, though. Issues: * I tested with SBCL-0.8.15, and occasionally I get Apache "internal server errors" (caused by SIGPIPE errors on the Lisp side). It seems to be dependant on which file is uploaded. I did not look into it yet... * DOES NOT provide functionality to handle transfer encodings. The application is on its own there for now. Mind you, the whole thing is just a first try. Perhaps it needs a better/richer API, too, but this one is simple, and works for me, YMMV. Cheers, Michael p.s.: I noticed, there is at least one other CL rfc2388 implementation available, in mel-base. -------------- next part -------------- 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)) From edi at agharta.de Wed Oct 27 21:49:37 2004 From: edi at agharta.de (Edi Weitz) Date: Wed, 27 Oct 2004 23:49:37 +0200 Subject: [tbnl-devel] multipart/form-data forms, RFC2388, File Uploads In-Reply-To: <20041027210417.GA2668@roadkill.foldr.org> (Michael Weber's message of "Wed, 27 Oct 2004 23:04:17 +0200") References: <20041027210417.GA2668@roadkill.foldr.org> Message-ID: On Wed, 27 Oct 2004 23:04:17 +0200, Michael Weber wrote: > Attached is a patch with my stab at file upload capabilities for > TBNL. :) Hi Michael! Thanks for providing this! I don't think I'll find the time to review it and release a new version this week, so I encourage other users of TBNL to apply the patch and try on their own. (And please report your results to the mailing list.) If you haven't heard back from me until next tuesday or so please remind me... :) Thanks again, Edi. From astebakov at yahoo.com Fri Oct 29 22:03:44 2004 From: astebakov at yahoo.com (Andrew Stebakov) Date: Fri, 29 Oct 2004 15:03:44 -0700 (PDT) Subject: [tbnl-devel] embedding lisp inside html Message-ID: <20041029220344.77512.qmail@web52803.mail.yahoo.com> Hi, I was wondering if it's possible to embed lisp in html the way PHP does? I really want to try switching from PHP to lisp and I have a web site that has a bunch of pages with PHP script (*.php ones). The only examples of lisp I've seen so far were pure lisp scripts that generate html. So, how about a mixture of html and lisp in one page? Thanks in advance. Andrei __________________________________________________ Do You Yahoo!? Tired of spam? Yahoo! Mail has the best spam protection around http://mail.yahoo.com From sscholl at common-lisp.net Fri Oct 29 22:33:31 2004 From: sscholl at common-lisp.net (Stefan Scholl) Date: Sat, 30 Oct 2004 00:33:31 +0200 Subject: [tbnl-devel] embedding lisp inside html In-Reply-To: <20041029220344.77512.qmail@web52803.mail.yahoo.com> References: <20041029220344.77512.qmail@web52803.mail.yahoo.com> Message-ID: <4182C53B.90605@common-lisp.net> On 2004-10-30 00:03, Andrew Stebakov wrote: > I was wondering if it's possible to embed lisp in html > the way PHP does? I really want to try switching from > PHP to lisp and I have a web site that has a bunch of > pages with PHP script (*.php ones). CL-EMB is a library to embed Common Lisp and special template tags into text (e.g. HTML). > The only examples of lisp I've seen so far were pure > lisp scripts that generate html. So, how about a > mixture of html and lisp in one page? Some examples for CL-EMB: http://common-lisp.net/project/cl-emb/examples.html