cl-rw

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

demo-counter2.lisp (10766B)

      1 ;;; Copyright (C) 2013, 2014, 2015, 2016 Tomas Hlavaty <tom@logand.com>
      2 ;;;
      3 ;;; Permission is hereby granted, free of charge, to any person
      4 ;;; obtaining a copy of this software and associated documentation
      5 ;;; files (the "Software"), to deal in the Software without
      6 ;;; restriction, including without limitation the rights to use, copy,
      7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
      8 ;;; of the Software, and to permit persons to whom the Software is
      9 ;;; furnished to do so, subject to the following conditions:
     10 ;;;
     11 ;;; The above copyright notice and this permission notice shall be
     12 ;;; included in all copies or substantial portions of the Software.
     13 ;;;
     14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
     20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     21 ;;; DEALINGS IN THE SOFTWARE.
     22 
     23 ;;; TODO post forms
     24 
     25 (defpackage :rw.demo.counter2
     26   (:use :cl))
     27 
     28 (in-package :rw.demo.counter2)
     29 
     30 (defvar *query-parameters*)
     31 (defvar *state-alist*)
     32 (defvar *action*)
     33 (defvar *widget-path*)
     34 (defvar *widget-child*)
     35 (defvar *action-index*)
     36 (defvar *var-index*)
     37 (defvar *getters*)
     38 
     39 (defun encode-var (value stream)
     40   (etypecase value
     41     (null)
     42     (integer
     43      (unless (minusp value)
     44        (write-char #\+ stream))
     45      (princ value stream))))
     46 
     47 (defun decode-var (x)
     48   (when x
     49     (ecase (char x 0)
     50       ((#\+ #\-) (parse-integer x)))))
     51 
     52 (defun encode-url (state-alist action)
     53   (with-output-to-string (s)
     54     (write-string "?" s)
     55     (loop
     56        for x in state-alist
     57        for i from 0
     58        do (progn
     59             (when (plusp i)
     60               (write-char #\& s))
     61             (write-string (car x) s)
     62             (write-char #\= s))
     63          (encode-var (cdr x) s))
     64     (when (and state-alist action)
     65       (write-string "&" s))
     66     (when action
     67       (write-string "a=" s)
     68       (write-string action s))))
     69 
     70 (defun decode-url ()
     71   (loop
     72      for x in *query-parameters*
     73      if (equal "a" (car x))
     74      collect (cdr x) into action
     75      else collect (cons (car x) (decode-var (cdr x))) into state-alist
     76      finally (return (values state-alist (car action)))))
     77 
     78 (defun encode-path (path i)
     79   (with-output-to-string (s)
     80     (when path
     81       (princ (car path) s)
     82       (dolist (x (cdr path))
     83         (write-char #\: s)
     84         (princ x s)))
     85     (write-char #\; s)
     86     (princ i s)))
     87 
     88 (defun lookup-var (path)
     89   (cdr (assoc path *state-alist* :test #'equal)))
     90 
     91 (defun widget-var (default get set &optional id)
     92   (let ((path (encode-path *widget-path* (incf *var-index*))))
     93     (funcall set (or (and id (lookup-var id))
     94                      (lookup-var path)
     95                      default))
     96     (when *action*
     97       (push (lambda () (cons (or id path) (funcall get))) *getters*))))
     98 
     99 (defun widget (thunk)
    100   (lambda ()
    101     (let ((*widget-path* (cons (incf *widget-child*) *widget-path*))
    102           (*widget-child* 0)
    103           (*action-index* 0)
    104           (*var-index* 0))
    105       (funcall thunk))))
    106 
    107 (defun widget-action (thunk)
    108   (let ((path (encode-path *widget-path* (incf *action-index*))))
    109     (lambda ()
    110       (if *action*
    111           (when (equal *action* path)
    112             (funcall thunk)
    113             nil)
    114           (encode-url *state-alist* path)))))
    115 
    116 (defun draw (thunk)
    117   (multiple-value-bind (*state-alist* *action*) (ignore-errors (decode-url))
    118     (let (*widget-path*
    119           (*widget-child* 0)
    120           *getters*
    121           (rw.ui::*click-link* (lambda (x) (funcall x)))
    122           (rw.ui::*click-form* (lambda (x) (funcall x))) ;;;;;;;;;;;
    123           (w (funcall thunk)))
    124       (if *action*
    125           (progn
    126             (funcall w)
    127             (rw.ui::http-redirect
    128              (encode-url (mapcar #'funcall *getters*) nil)))
    129           `(:http-1.0
    130             :code 200
    131             :headers (("Content-Type" . "text/html;charset=utf-8")
    132                       ("cache-control" . "no-cache,no-store")
    133                       ("pragma" . "no-cache")
    134                       ("expires" . "-1"))
    135             :body ,(funcall w))))))
    136 
    137 ;;; example
    138 
    139 (defun counter-widget (i)
    140   (let (n)
    141     (widget
    142      (lambda ()
    143        (widget-var 0 (lambda () n) (lambda (x) (setq n x)))
    144        `(:p ,i ": "
    145             " " ,(rw.ui:link "up" (widget-action (lambda () (incf n))))
    146             " " ,(rw.ui:link "down" (widget-action (lambda () (decf n))))
    147             " " (:b ,n))))))
    148 
    149 (defun calendar-widget (year0 month0 &key (first-weekday 0) (show-weeks t))
    150   (let (year month)
    151     (widget
    152      (lambda ()
    153        (widget-var year0 (lambda () year) (lambda (x) (setq year x)))
    154        (widget-var month0 (lambda () month) (lambda (x) (setq month x)))
    155        (let ((weeks (when show-weeks (rw.calendar::week-generator year month))))
    156          `((:table :style "font-family:monospace")
    157            (:tr
    158             ,@(when weeks '((:td "")))
    159             ((:td :colspan 3 :align "center")
    160              ,(rw.ui:link "<" (widget-action
    161                                (lambda ()
    162                                  (decf month)
    163                                  (when (< month 1)
    164                                    (decf year)
    165                                    (setq month 12)))))
    166              " " ,(rw.calendar::pretty-month month) " "
    167              ,(rw.ui:link ">" (widget-action
    168                                (lambda ()
    169                                  (incf month)
    170                                  (when (< 12 month)
    171                                    (incf year)
    172                                    (setq month 1))))))
    173             ((:td :align "center")
    174              ,(rw.ui:link "@" (widget-action
    175                                (lambda () (setq year year0 month month0)))))
    176             ((:td :colspan 3 :align "center")
    177              ,(rw.ui:link "<" (widget-action
    178                                (lambda () (decf year))))
    179              " " ,year " "
    180              ,(rw.ui:link ">" (widget-action
    181                                (lambda () (incf year))))))
    182            (:tr
    183             ,@(when weeks '((:td "  ")))
    184             ,@(loop
    185                  with g = (rw.calendar::weekday-generator first-weekday)
    186                  for i from 0 below 7
    187                  for n = (funcall g)
    188                  collect `((:td :style
    189                                 (:style :color ,(when (rw.calendar::weekend n) "red")))
    190                            ,(rw.calendar::pretty-day n))))
    191            ,@(loop
    192                 with g = (rw.calendar::day-generator year month first-weekday)
    193                 for i from 0 below 6
    194                 collect `(:tr
    195                           ,@(when weeks `(((:td :align "right") ,(funcall weeks))))
    196                           ,@(loop
    197                                for j from 0 below 7
    198                                for d = (funcall g)
    199                                collect `((:td :align "right")
    200                                          ,(if d
    201                                               (rw.ui:link d (widget-action
    202                                                              (lambda ())))
    203                                               "")))))))))))
    204 
    205 (defun form (draw)
    206   `((:form
    207      :action ,(funcall rw.ui::*click-link* (widget-action 'rw.ui::no))
    208      :method "post"
    209      :enctype "multipart/form-data"
    210      :style "padding:0;margin:0;border:0")
    211     ((:div :style "width:0;height:0;overflow:hidden")
    212      ,(rw.ui:submit nil (widget-action 'rw.ui::no1)))
    213     ,(if (functionp draw) (funcall draw) draw)))
    214 
    215 (defun var-widget (id)
    216   (let (v)
    217     (widget
    218      (lambda ()
    219        (widget-var 0 (lambda () v) (lambda (x) (setq v x)) id)
    220        (progn ;;form
    221         `(:p ,id "=" ,v " "
    222              #+nil ,(rw.ui:entry (lambda (x)) (princ-to-string v))
    223              #+nil ,(rw.ui:submit "ok" (lambda (x) (print (list :@@@ x))))))))))
    224 
    225 (defun toplevel-widget ()
    226   (let ((w (nconc
    227             (mapcar 'counter-widget '(1 2 3 4))
    228             (list
    229              (calendar-widget 2012 7)
    230              (calendar-widget 2013 8)
    231              (var-widget "v1")
    232              (var-widget "v2")))))
    233     (lambda ()
    234       `(:html
    235         (:head
    236          ((:meta :http-equiv "content-type"
    237                  :content "text/html;charset=utf-8"))
    238          ((:meta :http-equiv "cache-control" :content "no-cache,no-store"))
    239          ((:meta :http-equiv "pragma" :content "no-cache"))
    240          ((:meta :http-equiv "expires" :content -1))
    241          (:title "counter"))
    242         (:body ,@(mapcar #'funcall w))))))
    243 
    244 (defun draw-counter ()
    245   (draw (lambda () (toplevel-widget))))
    246 
    247 (defun counter-handler (msg stream method query protocol headers &optional body)
    248   (declare (ignore protocol headers))
    249   (ecase msg
    250     (:read (rw:till (rw:peek-reader stream)))
    251     (:write
    252      (let ((rw.ui:*http-server*
    253             (let ((pp (rw.http::post-parameters method body)))
    254               (lambda (msg &rest args)
    255                 (declare (ignore args))
    256                 (ecase msg
    257                   (:method method)
    258                   (:post-parameters pp)))))
    259            (*query-parameters* (nth-value 1 (rw.uri:parse-query-string query))))
    260        (draw-counter)))))
    261 
    262 (defun start ()
    263   (rw.http:server (rw.socket:make-ipv4-address "0.0.0.0")
    264                   2349
    265                   'counter-handler
    266                   :quit (lambda () nil)
    267                   :allowed-methods '(:get :post)
    268                   :ignore-errors-p t))
    269 
    270 ;;(start)
    271 
    272 (defun save-image ()
    273   #-(or ccl sbcl)
    274   (error "TODO RW.DEMO.COUNTER::SAVE-IMAGE")
    275   #+ccl ;; TODO no debug on ^C
    276   (ccl:save-application "cl-rw-demo-counter"
    277                         :prepend-kernel t
    278                         :error-handler :quit-quietly
    279                         :toplevel-function (lambda ()
    280                                              (handler-case
    281                                                  (progn
    282                                                    (start)
    283                                                    (loop (sleep 1)))
    284                                                (condition ()
    285                                                  (ccl:quit 1)))))
    286   #+sbcl
    287   (sb-ext:save-lisp-and-die "cl-rw-demo-counter"
    288                             :executable t
    289                             :toplevel (lambda ()
    290                                         (handler-case
    291                                             (progn
    292                                               (start)
    293                                               (loop (sleep 1)))
    294                                           (condition ()
    295                                             (sb-ext:exit :code 1 :abort t))))))