cl-rw

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

commit 67e5c7284c0364ca89ccdbe31598881f0d316329
parent 3b600f7f2c52789075c0ad6f422d76ce020c3228
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sun, 16 Oct 2016 23:53:08 +0200

try to store state in url instead on server in pool

Diffstat:
Ademo-counter2.lisp | 295+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Ademo-counter3.lisp | 345+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 640 insertions(+), 0 deletions(-)

diff --git a/demo-counter2.lisp b/demo-counter2.lisp @@ -0,0 +1,295 @@ +;;; Copyright (C) 2013, 2014, 2015, 2016 Tomas Hlavaty <tom@logand.com> +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, copy, +;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;; of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +;;; TODO post forms + +(defpackage :rw.demo.counter2 + (:use :cl)) + +(in-package :rw.demo.counter2) + +(defvar *query-parameters*) +(defvar *state-alist*) +(defvar *action*) +(defvar *widget-path*) +(defvar *widget-child*) +(defvar *action-index*) +(defvar *var-index*) +(defvar *getters*) + +(defun encode-var (value stream) + (etypecase value + (null) + (integer + (unless (minusp value) + (write-char #\+ stream)) + (princ value stream)))) + +(defun decode-var (x) + (when x + (ecase (char x 0) + ((#\+ #\-) (parse-integer x))))) + +(defun encode-url (state-alist action) + (with-output-to-string (s) + (write-string "?" s) + (loop + for x in state-alist + for i from 0 + do (progn + (when (plusp i) + (write-char #\& s)) + (write-string (car x) s) + (write-char #\= s)) + (encode-var (cdr x) s)) + (when (and state-alist action) + (write-string "&" s)) + (when action + (write-string "a=" s) + (write-string action s)))) + +(defun decode-url () + (loop + for x in *query-parameters* + if (equal "a" (car x)) + collect (cdr x) into action + else collect (cons (car x) (decode-var (cdr x))) into state-alist + finally (return (values state-alist (car action))))) + +(defun encode-path (path i) + (with-output-to-string (s) + (when path + (princ (car path) s) + (dolist (x (cdr path)) + (write-char #\: s) + (princ x s))) + (write-char #\; s) + (princ i s))) + +(defun lookup-var (path) + (cdr (assoc path *state-alist* :test #'equal))) + +(defun widget-var (default get set &optional id) + (let ((path (encode-path *widget-path* (incf *var-index*)))) + (funcall set (or (and id (lookup-var id)) + (lookup-var path) + default)) + (when *action* + (push (lambda () (cons (or id path) (funcall get))) *getters*)))) + +(defun widget (thunk) + (lambda () + (let ((*widget-path* (cons (incf *widget-child*) *widget-path*)) + (*widget-child* 0) + (*action-index* 0) + (*var-index* 0)) + (funcall thunk)))) + +(defun widget-action (thunk) + (let ((path (encode-path *widget-path* (incf *action-index*)))) + (lambda () + (if *action* + (when (equal *action* path) + (funcall thunk) + nil) + (encode-url *state-alist* path))))) + +(defun draw (thunk) + (multiple-value-bind (*state-alist* *action*) (ignore-errors (decode-url)) + (let (*widget-path* + (*widget-child* 0) + *getters* + (rw.ui::*click-link* (lambda (x) (funcall x))) + (rw.ui::*click-form* (lambda (x) (funcall x))) ;;;;;;;;;;; + (w (funcall thunk))) + (if *action* + (progn + (funcall w) + (rw.ui::http-redirect + (encode-url (mapcar #'funcall *getters*) nil))) + `(:http-1.0 + :code 200 + :headers (("Content-Type" . "text/html;charset=utf-8") + ("cache-control" . "no-cache,no-store") + ("pragma" . "no-cache") + ("expires" . "-1")) + :body ,(funcall w)))))) + +;;; example + +(defun counter-widget (i) + (let (n) + (widget + (lambda () + (widget-var 0 (lambda () n) (lambda (x) (setq n x))) + `(:p ,i ": " + " " ,(rw.ui:link "up" (widget-action (lambda () (incf n)))) + " " ,(rw.ui:link "down" (widget-action (lambda () (decf n)))) + " " (:b ,n)))))) + +(defun calendar-widget (year0 month0 &key (first-weekday 0) (show-weeks t)) + (let (year month) + (widget + (lambda () + (widget-var year0 (lambda () year) (lambda (x) (setq year x))) + (widget-var month0 (lambda () month) (lambda (x) (setq month x))) + (let ((weeks (when show-weeks (rw.calendar::week-generator year month)))) + `((:table :style "font-family:monospace") + (:tr + ,@(when weeks '((:td ""))) + ((:td :colspan 3 :align "center") + ,(rw.ui:link "<" (widget-action + (lambda () + (decf month) + (when (< month 1) + (decf year) + (setq month 12))))) + " " ,(rw.calendar::pretty-month month) " " + ,(rw.ui:link ">" (widget-action + (lambda () + (incf month) + (when (< 12 month) + (incf year) + (setq month 1)))))) + ((:td :align "center") + ,(rw.ui:link "@" (widget-action + (lambda () (setq year year0 month month0))))) + ((:td :colspan 3 :align "center") + ,(rw.ui:link "<" (widget-action + (lambda () (decf year)))) + " " ,year " " + ,(rw.ui:link ">" (widget-action + (lambda () (incf year)))))) + (:tr + ,@(when weeks '((:td "  "))) + ,@(loop + with g = (rw.calendar::weekday-generator first-weekday) + for i from 0 below 7 + for n = (funcall g) + collect `((:td :style + (:style :color ,(when (rw.calendar::weekend n) "red"))) + ,(rw.calendar::pretty-day n)))) + ,@(loop + with g = (rw.calendar::day-generator year month first-weekday) + for i from 0 below 6 + collect `(:tr + ,@(when weeks `(((:td :align "right") ,(funcall weeks)))) + ,@(loop + for j from 0 below 7 + for d = (funcall g) + collect `((:td :align "right") + ,(if d + (rw.ui:link d (widget-action + (lambda ()))) + ""))))))))))) + +(defun form (draw) + `((:form + :action ,(funcall rw.ui::*click-link* (widget-action 'rw.ui::no)) + :method "post" + :enctype "multipart/form-data" + :style "padding:0;margin:0;border:0") + ((:div :style "width:0;height:0;overflow:hidden") + ,(rw.ui:submit nil (widget-action 'rw.ui::no1))) + ,(if (functionp draw) (funcall draw) draw))) + +(defun var-widget (id) + (let (v) + (widget + (lambda () + (widget-var 0 (lambda () v) (lambda (x) (setq v x)) id) + (progn ;;form + `(:p ,id "=" ,v " " + #+nil ,(rw.ui:entry (lambda (x)) (princ-to-string v)) + #+nil ,(rw.ui:submit "ok" (lambda (x) (print (list :@@@ x)))))))))) + +(defun toplevel-widget () + (let ((w (nconc + (mapcar 'counter-widget '(1 2 3 4)) + (list + (calendar-widget 2012 7) + (calendar-widget 2013 8) + (var-widget "v1") + (var-widget "v2"))))) + (lambda () + `(:html + (:head + ((:meta :http-equiv "content-type" + :content "text/html;charset=utf-8")) + ((:meta :http-equiv "cache-control" :content "no-cache,no-store")) + ((:meta :http-equiv "pragma" :content "no-cache")) + ((:meta :http-equiv "expires" :content -1)) + (:title "counter")) + (:body ,@(mapcar #'funcall w)))))) + +(defun draw-counter () + (draw (lambda () (toplevel-widget)))) + +(defun counter-handler (msg stream method query protocol headers &optional body) + (declare (ignore protocol headers)) + (ecase msg + (:read (rw:till (rw:peek-reader stream))) + (:write + (let ((rw.ui:*http-server* + (let ((pp (rw.http::post-parameters method body))) + (lambda (msg &rest args) + (declare (ignore args)) + (ecase msg + (:method method) + (:post-parameters pp))))) + (*query-parameters* (nth-value 1 (rw.uri:parse-query-string query)))) + (draw-counter))))) + +(defun start () + (rw.http:server (rw.socket:make-ipv4-address "0.0.0.0") + 2349 + 'counter-handler + :quit (lambda () nil) + :allowed-methods '(:get :post) + :ignore-errors-p t)) + +;;(start) + +(defun save-image () + #-(or ccl sbcl) + (error "TODO RW.DEMO.COUNTER::SAVE-IMAGE") + #+ccl ;; TODO no debug on ^C + (ccl:save-application "cl-rw-demo-counter" + :prepend-kernel t + :error-handler :quit-quietly + :toplevel-function (lambda () + (handler-case + (progn + (start) + (loop (sleep 1))) + (condition () + (ccl:quit 1))))) + #+sbcl + (sb-ext:save-lisp-and-die "cl-rw-demo-counter" + :executable t + :toplevel (lambda () + (handler-case + (progn + (start) + (loop (sleep 1))) + (condition () + (sb-ext:exit :code 1 :abort t)))))) diff --git a/demo-counter3.lisp b/demo-counter3.lisp @@ -0,0 +1,345 @@ +;;; Copyright (C) 2013, 2014, 2015, 2016 Tomas Hlavaty <tom@logand.com> +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, copy, +;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;; of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +(defpackage :rw.demo.counter2 + (:use :cl)) + +(in-package :rw.demo.counter2) + +(defvar *slet-state*) +(defvar *slet-state-decoded*) +(defvar *sflet-action*) +(defvar *slet-path*) +(defvar *slet-child*) +(defvar *sflet-path*) +(defvar *sflet-child*) +(defvar *widget-path*) +(defvar *widget-child*) +(defvar *action-index*) +(defvar *var-index*) +(defvar *slet-getters*) +(defvar *mode*) + +(defun encode-url (state action) + (with-output-to-string (s) + (write-string "?" s) + (when state + (write-string "s=" s) + (write-string state s)) + (when (and state action) + (write-string "&" s)) + (when action + (write-string "a=" s) + (write-string action s)))) + +(defun encode-path (path i) + (with-output-to-string (s) + (when path + (princ (car path) s) + (dolist (x (cdr path)) + (write-char #\: s) + (princ x s))) + (write-char #\; s) + (princ i s))) + +(defun var-reader (r) + (lambda () + (when (rw:peek r) + (assert (eql #\! (rw:next r))) + (cons (let ((x (rw:till r '(#\$)))) + (when x + (coerce x 'string))) + (progn + (assert (eql #\$ (rw:next r))) + (assert (member (rw:peek r) '(nil #\! #\+ #\-))) + (let ((x (rw:till r '(#\!)))) + (when x + (parse-integer (coerce x 'string))))))))) + +(defun decode-state (state) + (rw:till (rw:peek-reader (var-reader (rw:peek-reader (rw:reader state)))))) + +;;(decode-state "!1;1$!1;2$+3!2;1$-1") + +(defun lookup-var (path) + (cdr (assoc path *slet-state-decoded* :test #'equal))) + +(defun widget-var (default get set) + (let ((path (encode-path *widget-path* (incf *var-index*)))) + (funcall set (or (lookup-var path) default)) + (when (eq :step *mode*) + (push (lambda () (values path (funcall get))) *slet-getters*)))) + +(defmacro slet (vars &body body) + `(let ((*slet-path* (cons (incf *slet-child*) *slet-path*)) + (*slet-child* 0)) + (let ((slet-path *slet-path*)) + (let ,(loop + for x in vars + for i from 1 + collect (destructuring-bind (name value) + (if (atom x) `(,x nil) x) + `(,name + (or (lookup-var (encode-path slet-path ,i)) + ,value)))) + (when (eq :step *mode*) + ,@(loop + for x in vars + for i from 1 + collect (destructuring-bind (name value) + (if (atom x) `(,x nil) x) + (declare (ignore value)) + `(push (lambda () + (values (encode-path slet-path ,i) ,name)) + *slet-getters*)))) + ,@body)))) + +(defun widget (thunk) + (lambda () + (let ((*widget-path* (cons (incf *widget-child*) *widget-path*)) + (*widget-child* 0) + (*action-index* 0) + (*var-index* 0)) + (funcall thunk)))) + +(defun widget-action (thunk) + (let ((path (encode-path *widget-path* (incf *action-index*)))) + (lambda () + (ecase *mode* + (:draw + (encode-url *slet-state* path)) + (:step + (when (equal *sflet-action* path) + (funcall thunk)) + nil))))) + +(defmacro sflet (funs &body body) + `(let ((*sflet-path* (cons (incf *sflet-child*) *sflet-path*)) + (*sflet-child* 0)) + (let ((sflet-path *sflet-path*)) + (flet ,(loop + for x in funs + for i from 1 + collect (destructuring-bind (name args &body body) x + `(,name + ,args + (ecase *mode* + (:draw + (encode-url *slet-state* + (encode-path sflet-path ,i))) + (:step + (when (equal *sflet-action* + (encode-path sflet-path ,i)) + ,@body) + nil))))) + ,@body)))) + +(defun counter-widget (i) + (let ((n 0)) + (flet ((up () (incf n) (print (list :@@@ :up i n))) + (down () (decf n) (print (list :@@@ :down i n)))) + (widget + (lambda () + (widget-var 0 (lambda () n) (lambda (x) (setq n x))) + `(:p ,i ": " + " " ,(rw.ui:link "up" (widget-action #'up)) + " " ,(rw.ui:link "down" (widget-action #'down)) + " " (:b ,n))))))) + +(defun calendar-widget (year0 month0 &key (first-weekday 0) (show-weeks t)) + (let ((year year0) + (month month0)) + (flet ((nop ()) ;; problem, need link for each day + (previous-month () + (decf month) + (when (< month 1) + (decf year) + (setq month 12))) + (next-month () + (incf month) + (when (< 12 month) + (incf year) + (setq month 1))) + (reset () (setq year year0 month month0)) + (previous-year () (decf year)) + (next-year () (incf year))) + (widget + (lambda () + (widget-var year0 (lambda () year) (lambda (x) (setq year x))) + (widget-var month0 (lambda () month) (lambda (x) (setq month x))) + (let ((weeks (when show-weeks (rw.calendar::week-generator year month)))) + `((:table :style "font-family:monospace") + (:tr + ,@(when weeks '((:td ""))) + ((:td :colspan 3 :align "center") + ,(rw.ui:link "<" (widget-action #'previous-month)) + " " ,(rw.calendar::pretty-month month) " " + ,(rw.ui:link ">" (widget-action #'next-month))) + ((:td :align "center") ,(rw.ui:link "@" (widget-action #'reset))) + ((:td :colspan 3 :align "center") + ,(rw.ui:link "<" (widget-action #'previous-year)) + " " ,year " " + ,(rw.ui:link ">" (widget-action #'next-year)))) + (:tr + ,@(when weeks '((:td "  "))) + ,@(loop + with g = (rw.calendar::weekday-generator first-weekday) + for i from 0 below 7 + for n = (funcall g) + collect `((:td :style + (:style :color ,(when (rw.calendar::weekend n) "red"))) + ,(rw.calendar::pretty-day n)))) + ,@(loop + with g = (rw.calendar::day-generator year month first-weekday) + for i from 0 below 6 + collect `(:tr + ,@(when weeks `(((:td :align "right") ,(funcall weeks)))) + ,@(loop + for j from 0 below 7 + for d = (funcall g) + collect `((:td :align "right") + ,(if d + (rw.ui:link d (widget-action #'nop)) + "")))))))))))) + +(defun toplevel-widget () + (let ((w (mapcar 'counter-widget '(1 2 3 4))) + (w2 (calendar-widget 2012 7))) + (lambda () + `(:html + (:head + ((:meta :http-equiv "content-type" + :content "text/html;charset=utf-8")) + ((:meta :http-equiv "cache-control" :content "no-cache,no-store")) + ((:meta :http-equiv "pragma" :content "no-cache")) + ((:meta :http-equiv "expires" :content -1)) + (:title "counter")) + (:body ,@(mapcar #'funcall w) ,(funcall w2)))))) + +(defvar *query-parameters*) + +(defun query-parameter (key) + (cdr (assoc key *query-parameters* :test #'equal))) + +(defun draw-counter () + (let* ((*slet-state* (query-parameter "s")) + (*slet-state-decoded* (ignore-errors (decode-state *slet-state*))) + (*sflet-action* (query-parameter "a")) + *slet-path* + (*slet-child* 0) + *sflet-path* + (*sflet-child* 0) + *widget-path* + (*widget-child* 0) + *slet-getters* + (*mode* (if *sflet-action* :step :draw)) + (rw.ui::*click-link* (lambda (click) (funcall click))) + #+nil(rw.ui::*click-form* (lambda (set) "TODO"))) + (let ((w (toplevel-widget))) + (ecase *mode* + (:step + (funcall w) + (rw.ui::http-redirect + (encode-url (with-output-to-string (s) + (dolist (x *slet-getters*) + (multiple-value-bind (k v) (funcall x) + (write-char #\! s) + (write-string k s) + (write-char #\$ s) + (etypecase v + (null) + (integer + (unless (minusp v) + (write-char #\+ s)) + (princ v s)))))) + nil))) + (:draw + `(:http-1.0 + :code 200 + :headers (("Content-Type" . "text/html;charset=utf-8") + ("cache-control" . "no-cache,no-store") + ("pragma" . "no-cache") + ("expires" . "-1")) + :body ,(funcall w)))))) + #+nil + (rw.ui:draw (lambda () + (let ((w (toplevel-widget))) + (lambda () + `(:http-1.0 + :code 200 + :headers (("Content-Type" . "text/html;charset=utf-8") + ("cache-control" . "no-cache,no-store") + ("pragma" . "no-cache") + ("expires" . "-1")) + :body ,(funcall w))))) + 'construct + 'deconstruct)) + +(defun counter-handler (msg stream method query protocol headers &optional body) + (declare (ignore protocol headers)) + (ecase msg + (:read (rw:till (rw:peek-reader stream))) + (:write + (let ((rw.ui:*http-server* + (let ((pp (rw.http::post-parameters method body))) + (lambda (msg &rest args) + (declare (ignore args)) + (ecase msg + (:method method) + (:post-parameters pp))))) + (*query-parameters* (nth-value 1 (rw.uri:parse-query-string query)))) + (draw-counter))))) + +(defun start () + (rw.http:server (rw.socket:make-ipv4-address "0.0.0.0") + 2349 + 'counter-handler + :quit (lambda () nil) + :allowed-methods '(:get :post) + :ignore-errors-p t)) + +;;(start) + +(defun save-image () + #-(or ccl sbcl) + (error "TODO RW.DEMO.COUNTER::SAVE-IMAGE") + #+ccl ;; TODO no debug on ^C + (ccl:save-application "cl-rw-demo-counter" + :prepend-kernel t + :error-handler :quit-quietly + :toplevel-function (lambda () + (handler-case + (progn + (start) + (loop (sleep 1))) + (condition () + (ccl:quit 1))))) + #+sbcl + (sb-ext:save-lisp-and-die "cl-rw-demo-counter" + :executable t + :toplevel (lambda () + (handler-case + (progn + (start) + (loop (sleep 1))) + (condition () + (sb-ext:exit :code 1 :abort t))))))