cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

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:
Mhttp.lisp | 64++++++++++++++++++++++++++++++++++++----------------------------
Mui.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)