cl-rw

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

demo-counter.lisp (5061B)

      1 ;;; Copyright (C) 2013, 2014, 2015 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.counter
     24   (:use :cl))
     25 
     26 (in-package :rw.demo.counter)
     27 
     28 (defun counter-widget (i rvar)
     29   (let ((n 0)) ;;rw.ui:slet ((n 0 rvar))
     30     (lambda ()
     31       `(:p ,i ": "
     32            " " ,(rw.ui:link "up" (lambda () (incf n)))
     33            " " ,(rw.ui:link "down" (lambda () (decf n)))
     34            " " (:b ,n)))))
     35 
     36 (defun toplevel-widget ()
     37   (let ((w (mapcar 'counter-widget '(1 2 3 4) '(i j x y)))
     38         (w2 (rw.ui:calendar-widget 2012 7)))
     39     (lambda ()
     40       `(:html
     41         (:head
     42          ((:meta :http-equiv "content-type"
     43                  :content "text/html;charset=utf-8"))
     44          ((:meta :http-equiv "cache-control" :content "no-cache,no-store"))
     45          ((:meta :http-equiv "pragma" :content "no-cache"))
     46          ((:meta :http-equiv "expires" :content -1))
     47          (:title "counter"))
     48         (:body ,@(mapcar #'funcall w) ,(funcall w2))))))
     49 
     50 (defun construct (sid aid renv)
     51   (let ((prefix "/"))
     52     (with-output-to-string (s)
     53       (format s "~a?s=~a&a=~a" prefix sid aid)
     54       (loop
     55          for (k v) on renv by #'cddr
     56          when v
     57          do (format s "&~(~a~)=~a" k v)))))
     58 
     59 (defvar *query-parameters*)
     60 
     61 (defun query-parameter (key)
     62   (cdr (assoc key *query-parameters* :test #'equal)))
     63 
     64 (defun deconstruct ()
     65   (values (query-parameter "s")
     66           (query-parameter "a")))
     67 
     68 (defun draw-counter ()
     69   (rw.ui:draw (lambda ()
     70                 (let ((w (toplevel-widget)))
     71                   (lambda ()
     72                     `(:http-1.0
     73                       :code 200
     74                       :headers (("Content-Type" . "text/html;charset=utf-8")
     75                                 ("cache-control" . "no-cache,no-store")
     76                                 ("pragma" . "no-cache")
     77                                 ("expires" . "-1"))
     78                       :body ,(funcall w)))))
     79               'construct
     80               'deconstruct))
     81 
     82 (defun counter-handler (msg stream method query protocol headers &optional body)
     83   (declare (ignore protocol headers))
     84   (ecase msg
     85     (:read (rw:till (rw:peek-reader stream)))
     86     (:write
     87      (let ((rw.ui:*http-server*
     88             (let ((pp (rw.http::post-parameters method body)))
     89               (lambda (msg &rest args)
     90                 (declare (ignore args))
     91                 (ecase msg
     92                   (:method method)
     93                   (:post-parameters pp)))))
     94            (*query-parameters* (nth-value 1 (rw.uri:parse-query-string query))))
     95        (draw-counter)))))
     96 
     97 (defun start ()
     98   (rw.http:server (rw.socket:make-ipv4-address "0.0.0.0")
     99                   2349
    100                   'counter-handler
    101                   :quit (lambda () nil)
    102                   :allowed-methods '(:get :post)
    103                   :ignore-errors-p t))
    104 
    105 ;;(start)
    106 
    107 (defun save-image ()
    108   #-(or ccl sbcl)
    109   (error "TODO RW.DEMO.COUNTER::SAVE-IMAGE")
    110   #+ccl ;; TODO no debug on ^C
    111   (ccl:save-application "cl-rw-demo-counter"
    112                         :prepend-kernel t
    113                         :error-handler :quit-quietly
    114                         :toplevel-function (lambda ()
    115                                              (handler-case
    116                                                  (progn
    117                                                    (start)
    118                                                    (loop (sleep 1)))
    119                                                (condition ()
    120                                                  (ccl:quit 1)))))
    121   #+sbcl
    122   (sb-ext:save-lisp-and-die "cl-rw-demo-counter"
    123                             :executable t
    124                             :toplevel (lambda ()
    125                                         (handler-case
    126                                             (progn
    127                                               (start)
    128                                               (loop (sleep 1)))
    129                                           (condition ()
    130                                             (sb-ext:exit :code 1 :abort t))))))