cl-rw

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

demo-counter3.lisp (10812B)

      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 (defpackage :rw.demo.counter3
     24   (:use :cl))
     25 
     26 (in-package :rw.demo.counter3)
     27 
     28 (defvar *slet-state*)
     29 (defvar *slet-state-decoded*)
     30 (defvar *sflet-action*)
     31 (defvar *widget-path*)
     32 (defvar *widget-child*)
     33 (defvar *action-index*)
     34 (defvar *var-index*)
     35 (defvar *slet-getters*)
     36 
     37 (defun encode-url (state action)
     38   (with-output-to-string (s)
     39     (write-string "?" s)
     40     (when state
     41       (write-string "s=" s)
     42       (write-string state s))
     43     (when (and state action)
     44       (write-string "&" s))
     45     (when action
     46       (write-string "a=" s)
     47       (write-string action s))))
     48 
     49 (defun encode-path (path i)
     50   (with-output-to-string (s)
     51     (when path
     52       (princ (car path) s)
     53       (dolist (x (cdr path))
     54         (write-char #\! s)
     55         (princ x s)))
     56     (write-char #\! s)
     57     (princ i s)))
     58 
     59 (defun var-reader (r)
     60   (lambda ()
     61     (when (rw:peek r)
     62       (assert (eql #\! (rw:next r)))
     63       (cons (let ((x (rw:till r '(#\.))))
     64               (when x
     65                 (coerce x 'string)))
     66             (progn
     67               (assert (eql #\. (rw:next r)))
     68               (assert (member
     69                        (rw:peek r)
     70                        '(nil #\! #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))
     71               (let ((x (rw:till r '(#\!))))
     72                 (when x
     73                   (parse-integer (coerce x 'string)))))))))
     74 
     75 (defun decode-state (state)
     76   (rw:till (rw:peek-reader (var-reader (rw:peek-reader (rw:reader state))))))
     77 
     78 ;;(decode-state "!1!1.!1!2.3!2!1.-1")
     79 
     80 (defun encode-state ()
     81   (with-output-to-string (s)
     82     (dolist (x *slet-getters*)
     83       (multiple-value-bind (k v) (funcall x)
     84         (write-char #\! s)
     85         (write-string k s)
     86         (write-char #\. s)
     87         (etypecase v
     88           (null)
     89           (integer (princ v s)))))))
     90 
     91 (defun lookup-var (path)
     92   (cdr (assoc path *slet-state-decoded* :test #'equal)))
     93 
     94 (defun widget-var (default get set)
     95   (let ((path (encode-path *widget-path* (incf *var-index*))))
     96     (funcall set (or (lookup-var path) default))
     97     (when *sflet-action*
     98       ;; TODO when == default => dont put into state
     99       (push (lambda () (values path (funcall get))) *slet-getters*))))
    100 
    101 (defun widget (thunk)
    102   (lambda ()
    103     (let ((*widget-path* (cons (incf *widget-child*) *widget-path*))
    104           (*widget-child* 0)
    105           (*action-index* 0)
    106           (*var-index* 0))
    107       (funcall thunk))))
    108 
    109 (defun widget-action (thunk)
    110   (let ((path (encode-path *widget-path* (incf *action-index*))))
    111     (lambda ()
    112       (if *sflet-action*
    113           (when (equal *sflet-action* path)
    114             (funcall thunk)
    115             nil)
    116           (encode-url *slet-state* path)))))
    117 
    118 (defun counter-widget (i)
    119   (let ((n 0))
    120     (flet ((up () (incf n))
    121            (down () (decf n)))
    122       (widget
    123        (lambda ()
    124          (widget-var 0 (lambda () n) (lambda (x) (setq n x)))
    125          `(:p ,i ": "
    126               " " ,(rw.ui:link "up" (widget-action #'up))
    127               " " ,(rw.ui:link "down" (widget-action #'down))
    128               " " (:b ,n)))))))
    129 
    130 (defun calendar-widget (year0 month0 &key (first-weekday 0) (show-weeks t))
    131   (let ((year year0)
    132         (month month0))
    133     (flet ((nop ()) ;; problem, need link for each day
    134            (previous-month ()
    135              (decf month)
    136              (when (< month 1)
    137                (decf year)
    138                (setq month 12)))
    139            (next-month ()
    140              (incf month)
    141              (when (< 12 month)
    142                (incf year)
    143                (setq month 1)))
    144            (reset () (setq year year0 month month0))
    145            (previous-year () (decf year))
    146            (next-year () (incf year)))
    147       (widget
    148        (lambda ()
    149          (widget-var year0 (lambda () year) (lambda (x) (setq year x)))
    150          (widget-var month0 (lambda () month) (lambda (x) (setq month x)))
    151          (let ((weeks (when show-weeks (rw.calendar::week-generator year month))))
    152            `((:table :style "font-family:monospace")
    153              (:tr
    154               ,@(when weeks '((:td "")))
    155               ((:td :colspan 3 :align "center")
    156                ,(rw.ui:link "<" (widget-action #'previous-month))
    157                " " ,(rw.calendar::pretty-month month) " "
    158                ,(rw.ui:link ">" (widget-action #'next-month)))
    159               ((:td :align "center") ,(rw.ui:link "@" (widget-action #'reset)))
    160               ((:td :colspan 3 :align "center")
    161                ,(rw.ui:link "<" (widget-action #'previous-year))
    162                " " ,year " "
    163                ,(rw.ui:link ">" (widget-action #'next-year))))
    164              (:tr
    165               ,@(when weeks '((:td "  ")))
    166               ,@(loop
    167                    with g = (rw.calendar::weekday-generator first-weekday)
    168                    for i from 0 below 7
    169                    for n = (funcall g)
    170                    collect `((:td :style
    171                                   (:style :color ,(when (rw.calendar::weekend n) "red")))
    172                              ,(rw.calendar::pretty-day n))))
    173              ,@(loop
    174                   with g = (rw.calendar::day-generator year month first-weekday)
    175                   for i from 0 below 6
    176                   collect `(:tr
    177                             ,@(when weeks `(((:td :align "right") ,(funcall weeks))))
    178                             ,@(loop
    179                                  for j from 0 below 7
    180                                  for d = (funcall g)
    181                                  collect `((:td :align "right")
    182                                            ,(if d
    183                                                 (rw.ui:link d (widget-action #'nop))
    184                                                 ""))))))))))))
    185 
    186 (defun toplevel-widget ()
    187   (let ((w (mapcar 'counter-widget '(1 2 3 4)))
    188         (w2 (calendar-widget 2012 7)))
    189     (lambda ()
    190       `(:html
    191         (:head
    192          ((:meta :http-equiv "content-type"
    193                  :content "text/html;charset=utf-8"))
    194          ((:meta :http-equiv "cache-control" :content "no-cache,no-store"))
    195          ((:meta :http-equiv "pragma" :content "no-cache"))
    196          ((:meta :http-equiv "expires" :content -1))
    197          (:title "counter"))
    198         (:body ,@(mapcar #'funcall w) ,(funcall w2))))))
    199 
    200 (defvar *query-parameters*)
    201 
    202 (defun query-parameter (key)
    203   (cdr (assoc key *query-parameters* :test #'equal)))
    204 
    205 (defun draw-counter ()
    206   (let* ((*slet-state* (query-parameter "s"))
    207          (*slet-state-decoded* (ignore-errors (decode-state *slet-state*)))
    208          (*sflet-action* (query-parameter "a"))
    209          *widget-path*
    210          (*widget-child* 0)
    211          *slet-getters*
    212          (rw.ui::*click-link* (lambda (click) (funcall click)))
    213          #+nil(rw.ui::*click-form* (lambda (set) "TODO")))
    214     (let ((w (toplevel-widget)))
    215       (if *sflet-action*
    216           (progn
    217             (funcall w)
    218             (rw.ui::http-redirect (encode-url (encode-state) nil)))
    219           `(:http-1.0
    220             :code 200
    221             :headers (("Content-Type" . "text/html;charset=utf-8")
    222                       ("cache-control" . "no-cache,no-store")
    223                       ("pragma" . "no-cache")
    224                       ("expires" . "-1"))
    225             :body ,(funcall w)))))
    226   #+nil
    227   (rw.ui:draw (lambda ()
    228                 (let ((w (toplevel-widget)))
    229                   (lambda ()
    230                     `(:http-1.0
    231                       :code 200
    232                       :headers (("Content-Type" . "text/html;charset=utf-8")
    233                                 ("cache-control" . "no-cache,no-store")
    234                                 ("pragma" . "no-cache")
    235                                 ("expires" . "-1"))
    236                       :body ,(funcall w)))))
    237               'construct
    238               'deconstruct))
    239 
    240 (defun counter-handler (msg stream method query protocol headers &optional body)
    241   (declare (ignore protocol headers))
    242   (ecase msg
    243     (:read (rw:till (rw:peek-reader stream)))
    244     (:write
    245      (let ((rw.ui:*http-server*
    246             (let ((pp (rw.http::post-parameters method body)))
    247               (lambda (msg &rest args)
    248                 (declare (ignore args))
    249                 (ecase msg
    250                   (:method method)
    251                   (:post-parameters pp)))))
    252            (*query-parameters* (nth-value 1 (rw.uri:parse-query-string query))))
    253        (draw-counter)))))
    254 
    255 (defun start ()
    256   (rw.http:server (rw.socket:make-ipv4-address "0.0.0.0")
    257                   2349
    258                   'counter-handler
    259                   :quit (lambda () nil)
    260                   :allowed-methods '(:get :post)
    261                   :ignore-errors-p t))
    262 
    263 ;;(start)
    264 
    265 (defun save-image ()
    266   #-(or ccl sbcl)
    267   (error "TODO RW.DEMO.COUNTER::SAVE-IMAGE")
    268   #+ccl ;; TODO no debug on ^C
    269   (ccl:save-application "cl-rw-demo-counter"
    270                         :prepend-kernel t
    271                         :error-handler :quit-quietly
    272                         :toplevel-function (lambda ()
    273                                              (handler-case
    274                                                  (progn
    275                                                    (start)
    276                                                    (loop (sleep 1)))
    277                                                (condition ()
    278                                                  (ccl:quit 1)))))
    279   #+sbcl
    280   (sb-ext:save-lisp-and-die "cl-rw-demo-counter"
    281                             :executable t
    282                             :toplevel (lambda ()
    283                                         (handler-case
    284                                             (progn
    285                                               (start)
    286                                               (loop (sleep 1)))
    287                                           (condition ()
    288                                             (sb-ext:exit :code 1 :abort t))))))