commit 2cc8e359f7f829feea53aa64fcc5170c3d2bafd6
parent 6585617e506123f0c619f49ba302f2bd7cdf3213
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 22 Sep 2013 18:13:41 +0200
added header parsing, post multipart/form-data handling, some fixes
Diffstat:
| M | http.lisp | | | 104 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------- |
| M | rw.lisp | | | 2 | +- |
| M | ui.lisp | | | 16 | ++++++++-------- |
3 files changed, 95 insertions(+), 27 deletions(-)
diff --git a/http.lisp b/http.lisp
@@ -1,3 +1,6 @@
+;; TODO remove all those coerce list<->string?
+;; TODO file(s) upload
+
(defpackage :rw.http
(:use :cl)
(:export :client
@@ -26,19 +29,54 @@
(rw:skip reader))
(prog1 (rw:next-z0 reader)
(rw:skip reader))
- (prog1 (coerce (rw:till reader '(#\return #'\newline)) 'string) ;; TODO better
+ (prog1 (coerce (rw:till reader '(#\return #'\newline)) 'string)
(next-eol reader)))))
+(defun header-part-reader (reader)
+ (lambda ()
+ (rw:skip reader)
+ (when (rw:peek reader)
+ (flet ((str (y)
+ (when y
+ (coerce y 'string))))
+ (cons (str (rw:till reader '(#\= #\;)))
+ (ecase (rw:next reader)
+ ((nil #\;) nil)
+ (#\=
+ (rw:skip reader)
+ (let ((q (when (eql #\" (rw:peek reader))
+ (rw:next reader)
+ t)))
+ (prog1 (str (rw:till reader '(#\")))
+ (when q
+ (assert (eql #\" (rw:next reader))))
+ (rw:skip reader)
+ (assert (member (rw:next reader) '(#\; nil))))))))))))
+
+(defun parse-header (k v)
+ (case (cdr (assoc k '(("Content-Length" . :z0)
+ ("Content-Disposition" . :header-parts)
+ ("Content-Type" . :header-parts))
+ :test #'equal))
+ (:z0 (rw:next-z0 (rw:peek-reader (rw:reader v))))
+ (:header-parts (rw:till (rw:peek-reader
+ (header-part-reader
+ (rw:peek-reader (rw:reader v))))))
+ (t (coerce v 'string))))
+
+;;(parse-header "Content-Disposition" "form-data; name=\"z7\"; filename=\"\"")
+;;(parse-header "Content-Type" "multipart/form-data; boundary=---------------------------333499860151468491119738773")
+
(defun header-reader (reader)
(lambda ()
(let ((k (rw:till reader '(#\: #\return #\newline))))
(when k
- (assert (eql #\: (rw:peek reader)))
- (rw:next reader)
+ (assert (eql #\: (rw:next reader)))
(rw:skip reader)
- (prog1 (cons (coerce k 'string) ;; TODO better
- (coerce (rw:till reader '(#\return #\newline)) 'string)) ;; TODO better
- (next-eol reader))))))
+ (let* ((kk (coerce k 'string))
+ (v (rw:till reader '(#\return #\newline))))
+ (next-eol reader)
+ (cons kk (parse-header kk v)))))))
(defun next-headers (reader)
(prog1 (rw:till (rw:peek-reader (header-reader reader)))
@@ -230,6 +268,39 @@
stream)
(write-crlf stream))
+(defun multipart-reader (reader start-boundary end-boundary)
+ (lambda ()
+ (rw:skip reader)
+ (when (rw:peek reader)
+ (let ((boundary (rw:till reader '(#\return #\newline))))
+ (unless (equal boundary end-boundary)
+ (assert (equalp boundary start-boundary))
+ (next-eol reader)
+ (list :part
+ :headers (next-headers reader)
+ :body (prog1 (rw:till reader '(#\return #\newline))
+ (next-eol reader))))))))
+
+(defun next-multipart/form-data (reader boundary)
+ (rw:till (rw:peek-reader (multipart-reader (rw:peek-reader reader)
+ `(#\- #\- ,@boundary)
+ `(#\- #\- ,@boundary #\- #\-)))))
+
+(defun post-parameters (method multipart/form-data)
+ (when (eq :post method)
+ (loop
+ for x in multipart/form-data
+ collect (destructuring-bind (tag &key headers body) x
+ (assert (eq :part tag))
+ (cons (let ((y (cdr (assoc "Content-Disposition" headers
+ :test #'equal))))
+ (assert (assoc "form-data" y :test #'equal))
+ ;;(cdr (assoc "filename" y :test #'equal))
+ ;;("Content-Type" ("application/octet-stream"))
+ (cdr (assoc "name" y :test #'equal)))
+ (when body
+ (coerce body 'string)))))))
+
(defun server-handler (stream handler)
(let ((r (rw:peek-reader (rw:char-reader stream))))
(multiple-value-bind (method query protocol) (next-query r)
@@ -237,18 +308,15 @@
(multiple-value-bind (protocol2 code message headers2 body)
(funcall handler :write stream method query protocol headers
(when (eq :post method)
- #+nil ;; TODO post
- (let ((n (cdr (assoc "Content-Length" headers :test #'equal))))
- (when n
- (funcall handler
- :read
- (rw:shorter-reader
- (rw:byte-reader stream)
- (rw:next-z0 (rw:peek-reader (rw:reader n))))
- method
- query
- protocol
- headers)))))
+ (next-multipart/form-data
+ (rw:shorter-reader
+ r
+ (cdr (assoc "Content-Length" headers :test #'equal)))
+ (coerce
+ (cdr (assoc "boundary"
+ (cdr (assoc "Content-Type" headers :test #'equal))
+ :test #'equal))
+ 'list))))
(write-status stream protocol2 code message)
(write-headers (or headers2
'(("Connection" . "close")
diff --git a/rw.lisp b/rw.lisp
@@ -150,7 +150,7 @@
(setf (aref z i) x)))))
(defun next-z0 (reader)
- (let ((x (rw:till reader '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 \9) t)))
+ (let ((x (rw:till reader '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) t)))
(when x
(parse-integer (coerce x 'string))))) ;; TODO better
diff --git a/ui.lisp b/ui.lisp
@@ -84,13 +84,13 @@
;;(print (list :@@@-a env1 svals))
(unwind-protect
(funcall fn
- (lambda (k p)
+ (lambda (k p nargs)
(let ((v (getf actions1 k)))
- (print (list :@@@ k p v))
+ ;;(print (list :@@@ k p method v))
(when v
- (if p
- (funcall v p)
- (funcall v)))))
+ (ecase nargs
+ (:arg0 (funcall v))
+ (:arg1 (funcall v p #+nil(or p "")))))))
(lambda ()
(unless env1
(setq svals (delete cached svals)))))
@@ -127,11 +127,11 @@
(destructuring-bind (k &rest v) x
(let ((kk (when (char= #\z (char k 0))
(parse36 (subseq k 1)))))
- (funcall dispatch kk v))))
- (funcall dispatch aid nil)
+ (funcall dispatch kk v :arg1))))
+ (funcall dispatch aid nil :arg0)
`(:redirect ,(funcall construct sid (pretty36 aid) *renv*)))
(:get
- (funcall dispatch aid nil)
+ (funcall dispatch aid nil :arg0)
(funcall clear)
(flet ((next (v)
(let ((k (incf n)))
