commit 55a594413ed0166f163bc437651931db5e86e739
parent 2929c1a9e4b59f8672fd3a760124cdaeff95c892
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 13 Oct 2013 16:03:04 +0200
handle http/ui resources/files as well as actions
- actions are base36 numbers, resources strings that
dont parse as base36 numbers (and passed to handler
as optional arg)
- also make http output protocol a "sexp based document"
and avoid intermediate translation code
Diffstat:
| M | http.lisp | | | 64 | ++++++++++++++++++++++++++++++++++++---------------------------- |
| M | ui.lisp | | | 104 | +++++++++++++++++++++++++++++++++++++------------------------------------------ |
2 files changed, 85 insertions(+), 83 deletions(-)
diff --git a/http.lisp b/http.lisp
@@ -305,32 +305,38 @@
(defun server-handler (stream handler)
(let ((r (rw:peek-reader (rw:char-reader stream))))
(multiple-value-bind (method query protocol) (next-query r)
- (let ((headers (next-headers r)))
- (multiple-value-bind (protocol2 code message headers2 body)
- (funcall handler :write stream method query protocol headers
- (when (eq :post method)
- (rw:slurp
- (multipart-reader
- (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")
- ;;("Date" . "")
- ;;("Last-Modified" . "")
- ("Server" . "CL-RW")))
- stream)
- (write-crlf stream)
- (etypecase body
- (null)
- (string (write-string body stream))
- (function (funcall body stream))))))))
+ (let ((form (let ((headers (next-headers r)))
+ (funcall handler :write stream method query protocol headers
+ (when (eq :post method)
+ (rw:slurp
+ (multipart-reader
+ (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))))))))
+ (ecase (car form)
+ (:http-1.0
+ (destructuring-bind (&key code message headers body) (cdr form)
+ (write-status stream :http-1.0 code message)
+ (write-headers (or headers
+ '(("Connection" . "close")
+ ;;("Date" . "")
+ ;;("Last-Modified" . "")
+ ("Server" . "CL-RW")))
+ stream)
+ (write-crlf stream)
+ (etypecase body
+ (null)
+ (string (write-string body stream))
+ (pathname
+ (with-open-file (in body :element-type '(unsigned-byte 8))
+ (rw:copy (rw:byte-reader in) (rw:byte-writer stream))))
+ (cons (let ((*standard-output* stream)) (rw.html:html body))) ;; TODO xml, css...
+ (function (funcall body stream))))))))))
(defun server-loop (socket quit handler host port)
(do ((q (or quit (rw:reader '(nil t)))))
@@ -356,7 +362,9 @@
(defun my-handler (msg stream method query protocol headers &optional body)
(ecase msg
(:read (rw:till (rw:peek-reader stream)))
- (:write (values :http-1.0 200 nil nil
- (prin1-to-string (list method query protocol headers body))))))
+ (:write `(:http-1.0
+ :code 200
+ :body ,(prin1-to-string
+ (list method query protocol headers body))))))
;;(server "0.0.0.0" 1567 'my-handler :quit (lambda () nil))
diff --git a/ui.lisp b/ui.lisp
@@ -34,12 +34,7 @@
(defun http-post-parameters ()
(funcall *http-server* :post-parameters))
-(defun set-http-header (k v)
- (funcall *http-server* :set-parameter k v))
-
-(defun http-redirect (url)
- (funcall *http-server* :redirect url))
-
+(defvar *resource-link*)
(defvar *click-link*)
(defvar *click-form*)
@@ -54,14 +49,6 @@
(values (parse-nat0 (subseq x 1 i))
(parse-nat0 (subseq x (1+ i))))))))
-(defun html-reply (form)
- (set-http-header "Content-Type" "text/html;charset=utf-8")
- (set-http-header "cache-control" "no-cache, no-store")
- (set-http-header "pragma" "no-cache")
- (set-http-header "expires" "-1")
- (with-output-to-string (*standard-output*)
- (rw.html:html form)))
-
(defvar *register*)
(defun make-state (create)
@@ -104,12 +91,10 @@
(defmacro with-state ((state aid actions2 dispatch clear) &body body)
`(funcall ,state ,aid ,actions2 (lambda (,dispatch ,clear) ,@body)))
-(defun handle-form (form)
- (ecase (car form)
- (:redirect
- (destructuring-bind (target) (cdr form)
- (http-redirect target)))
- (:html (html-reply form))))
+(defun http-redirect (url)
+ `(:http-1.0
+ :code 302
+ :headers (("Location" . ,url))))
(defvar *renv*)
@@ -117,40 +102,47 @@
(let ((n 0))
(multiple-value-bind (draw state) (make-state create)
(lambda (aid)
- (let (actions2)
- (with-state (state aid (lambda () actions2) dispatch clear)
- ;;(print (list :@@@ (hunchentoot:query-string*)))
- (handle-form
- (ecase (http-method)
- (:post
- (dolist (x (http-post-parameters))
- (destructuring-bind (k &rest v) x
- (let ((kk (when (char= #\z (char k 0))
- (parse36 (subseq k 1)))))
- (funcall dispatch kk v :arg1))))
- (funcall dispatch aid nil :arg0)
- `(:redirect ,(funcall construct sid (pretty36 aid) *renv*)))
- (:get
- (funcall dispatch aid nil :arg0)
- (funcall clear)
- (flet ((next (v)
- (let ((k (incf n)))
- (push v actions2)
- (push k actions2)
- k)))
- (let* ((*click-link*
- (lambda (click &optional idempotent)
- ;; TODO let rvars, "let explicit svars",
- ;; funcall click idempotent in regards to
- ;; implicit svars
- (let ((*renv* (copy-list *renv*)))
- ;;(funcall idempotent) TODO !!!!!!!!!!!!!!!!!
- (funcall construct sid (pretty36 (next click))
- *renv*))))
- (*click-form*
- (lambda (set)
- (format nil "z~a" (pretty36 (next set))))))
- (funcall draw))))))))))))
+ (etypecase aid
+ (string ;; resource
+ (ecase (http-method)
+ (:get (funcall draw aid))))
+ (integer ;; action
+ (let (actions2)
+ (with-state (state aid (lambda () actions2) dispatch clear)
+ ;;(print (list :@@@ (hunchentoot:query-string*)))
+ (ecase (http-method)
+ (:post
+ (dolist (x (http-post-parameters))
+ (destructuring-bind (k &rest v) x
+ (let ((kk (when (char= #\z (char k 0))
+ (parse36 (subseq k 1)))))
+ (funcall dispatch kk v :arg1))))
+ (funcall dispatch aid nil :arg0)
+ `(:redirect ,(funcall construct sid (pretty36 aid) *renv*)))
+ (:get
+ (funcall dispatch aid nil :arg0)
+ (funcall clear)
+ (flet ((next (v)
+ (let ((k (incf n)))
+ (push v actions2)
+ (push k actions2)
+ k)))
+ (let* ((*resource-link*
+ (lambda (rid)
+ (funcall construct sid rid nil #+nil *renv*)))
+ (*click-link*
+ (lambda (click &optional idempotent)
+ ;; TODO let rvars, "let explicit svars",
+ ;; funcall click idempotent in regards to
+ ;; implicit svars
+ (let ((*renv* (copy-list *renv*)))
+ ;;(funcall idempotent) TODO !!!!!!!!!!!!!!!!!
+ (funcall construct sid (pretty36 (next click))
+ *renv*))))
+ (*click-form*
+ (lambda (set)
+ (format nil "z~a" (pretty36 (next set))))))
+ (funcall draw)))))))))))))
(defmacro slet (vars &body body) ;; TODO renv
`(let ,(mapcar (lambda (x) (subseq x 0 2)) vars)
@@ -210,7 +202,9 @@
(lock (rw.concurrency:make-lock "pool ~s")))
(lambda (create deconstruct construct)
(multiple-value-bind (sid aid *renv*) (funcall deconstruct)
- (setq aid (parse36 aid))
+ (let ((aid2 (parse36 aid))) ;; number=action|string=resource
+ (when aid2
+ (setq aid aid2)))
(funcall
(rw.concurrency:with-lock (lock)
(maphash (lambda (k v)
