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:
| A | demo-counter2.lisp | | | 295 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | demo-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))))))
