/src/upload.lisp

 1(in-package :wu)
 2
 3(export '(parse-upload-form))
 4
 5;;; Call this to parse a multipart form.  
 6
 7;;; Returns a list of ((<field> <value>)..., where <value> will be a pathname for the file.
 8;;; Not thoroughly tested, this is a very annoying piece of the web protocol
 9
10(defun parse-upload-form (req &key (pathname-maker
11				    #'(lambda (name) (make-pathname :defaults (pathname "/tmp/") :name (string+ (string *session*) "_" name)))
12				    ))
13  (do ((result nil))
14      (())
15    (multiple-value-bind (part-type field filename content-type)
16	(parse-multipart-header (get-multipart-header req))
17      (declare (ignorable content-type))
18;      (format t "~%Multipart part-type=~s name=~s filename=~s content-type=~s~%" part-type field filename content-type)      
19      (case part-type
20	(:eof
21	 (return result))
22	(:file
23	 (let ((pathname (funcall pathname-maker filename))
24	       (element-type '(unsigned-byte 8)))
25	   (with-open-file (s pathname :direction :output :if-exists :supersede :element-type element-type)
26	     (slurp-part req :stream s :element-type element-type))
27	   (push (list field pathname) result)))
28	(:nofile
29	 (push (list field nil) result))
30	(:data
31	 (push (list field (slurp-part req)) 
32	       result))
33	(t (warn "Unknown part type ~A" part-type)
34	   (slurp-part req))))))		
35
36(defparameter *buffer-size* (* 4 1024))
37
38(defun slurp-part (req &key stream (element-type '(unsigned-byte 8)))
39  (loop with buffer = (make-array *buffer-size* :element-type element-type)
40     for n = (get-multipart-sequence req buffer)
41     with len = 0
42       ;; +++ will be wrong if there are multiple buffers, but that's unlikely for a non-file
43     finally (return (values (unless stream (vector->string buffer len)) len))
44     while n do
45       (incf len n)
46       (if stream
47           (write-sequence buffer stream :end n))))
48