[tbnl-devel] multipart/form-data forms, RFC2388, File Uploads
Michael Weber
michaelw+tbnl at foldr.org
Wed Oct 27 21:04:17 UTC 2004
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))
More information about the Tbnl-devel
mailing list