ui.lisp (22201B)
1 (defpackage :rw.ui 2 (:use :cl) 3 (:export :*http-server* 4 :calendar-widget 5 :checkbox 6 :choice-widget 7 :combo-item1-widget 8 :combo-item2-widget 9 :combo-widget 10 :dialog-widget 11 :draw 12 :entry 13 :file 14 :form 15 :hbox-widget 16 :link 17 :password 18 :popup-widget 19 :radio 20 :reset 21 :slet 22 :spin 23 :submit 24 :text 25 :vbox-widget 26 :visible-widget)) 27 28 (in-package :rw.ui) 29 30 (defvar *http-server*) 31 32 (defun http-method () 33 (funcall *http-server* :method)) 34 35 (defun http-post-parameters () 36 (funcall *http-server* :post-parameters)) 37 38 (defvar *resource-link*) 39 (defvar *click-link*) 40 (defvar *click-form*) 41 42 (defun parse-nat0 (x) 43 (when (and x (not (equal "" x)) (every #'digit-char-p x)) 44 (parse-integer x))) 45 46 (defun parse-ismap-value (x) 47 (when (and x (not (equal "" x)) (char= #\? (char x 0))) 48 (let ((i (position #\, x))) 49 (when (plusp i) 50 (values (parse-nat0 (subseq x 1 i)) 51 (parse-nat0 (subseq x (1+ i)))))))) 52 53 (defvar *register*) 54 55 (defun make-state (create) 56 (let (svars svals) 57 (flet ((store (actions) 58 (let ((env (mapcar (lambda (k) (funcall (car k))) svars))) 59 (when actions 60 (push (cons env actions) svals))))) 61 (values 62 (let ((*register* (lambda (get set) 63 (push (cons get set) svars)))) 64 (prog1 (funcall create) 65 (store (list 0 (lambda ()))))) 66 (lambda (aid actions2 fn) 67 (let ((cached (find-if (lambda (x) (getf (cdr x) aid)) svals))) 68 ;;(print (list :@@@======== aid cached)) 69 (if cached 70 (destructuring-bind (env1 &rest actions1) cached 71 (mapc (lambda (k v) (funcall (cdr k) v)) svars env1) 72 ;;(print (list :@@@-a env1 svals)) 73 (unwind-protect 74 (funcall fn 75 (lambda (k p nargs) 76 (let ((v (getf actions1 k))) 77 ;;(print (list :@@@ k p method v)) 78 (when v 79 (ecase nargs 80 (:arg0 (funcall v)) 81 (:arg1 (funcall v p #+nil(or p ""))))))) 82 (lambda () 83 (unless env1 84 (setq svals (delete cached svals))))) 85 (store (funcall actions2)) 86 #+nil(print (list :@@@-z svals)))) 87 ;; TODO indicate unexpected aid when not cached? 88 (funcall fn 89 (lambda (k p nargs) (declare (ignore k p nargs))) 90 (lambda ()))))))))) 91 92 (defmacro with-state ((state aid actions2 dispatch clear) &body body) 93 `(funcall ,state ,aid ,actions2 (lambda (,dispatch ,clear) ,@body))) 94 95 (defun http-redirect (url) 96 `(:http-1.0 97 :code 302 98 :headers (("Location" . ,url)))) 99 100 (defvar *renv*) 101 102 (defun make-stepper (sid create construct) 103 (let ((n 0)) 104 (multiple-value-bind (draw state) (make-state create) 105 (lambda (aid) 106 (etypecase aid 107 (string ;; resource 108 (ecase (http-method) 109 (:get (funcall draw aid)))) 110 (integer ;; action 111 (let (actions2) 112 (with-state (state aid (lambda () actions2) dispatch clear) 113 ;;(print (list :@@@ (hunchentoot:query-string*))) 114 (ecase (http-method) 115 (:post 116 (dolist (x (http-post-parameters)) 117 (destructuring-bind (k &rest v) x 118 (let ((kk (when (char= #\z (char k 0)) 119 (parse36 (subseq k 1))))) 120 (funcall dispatch kk v :arg1)))) 121 (funcall dispatch aid nil :arg0) 122 (http-redirect (funcall construct sid (pretty36 aid) *renv*))) 123 (:get 124 (funcall dispatch aid nil :arg0) 125 (funcall clear) 126 (flet ((next (v) 127 (let ((k (incf n))) 128 (push v actions2) 129 (push k actions2) 130 k))) 131 (let* ((*resource-link* 132 (lambda (rid) 133 (funcall construct sid rid nil #+nil *renv*))) 134 (*click-link* 135 (lambda (click &optional idempotent) 136 ;; TODO let rvars, "let explicit svars", 137 ;; funcall click idempotent in regards to 138 ;; implicit svars 139 (let ((*renv* (copy-list *renv*))) 140 ;;(funcall idempotent) TODO !!!!!!!!!!!!!!!!! 141 (funcall construct sid (pretty36 (next click)) 142 *renv*)))) 143 (*click-form* 144 (lambda (set) 145 (format nil "z~a" (pretty36 (next set)))))) 146 (funcall draw))))))))))))) 147 148 (defmacro slet (vars &body body) ;; TODO renv 149 `(let ,(mapcar (lambda (x) (subseq x 0 2)) vars) 150 ,@(mapcar (lambda (x) 151 `(funcall *register* 152 (lambda () ,(car x)) 153 (lambda (v) (setq ,(car x) v)))) 154 vars) 155 ,@body)) 156 157 (defparameter *session-lifespan* (* 60 60)) 158 159 (defun make-session (sid create construct) 160 (let ((l (rw.concurrency:make-lock "session ~s")) 161 (n (get-universal-time)) 162 (s (make-stepper sid create construct))) 163 (lambda (aid) 164 (rw.concurrency:using-lock 165 l 166 (lambda () 167 (cond 168 ((eq t aid) 169 (< (- (get-universal-time) n) *session-lifespan*)) 170 (t 171 (setq n (get-universal-time)) 172 (funcall s aid)))))))) 173 174 (defun rd (cnt) 175 (let ((s *standard-input*)) 176 (do ((n 0 (1+ n)) 177 (z (read-byte s) (+ (* 256 z) (read-byte s)))) 178 ((< cnt n) z)))) 179 180 (defun pretty36 (x) 181 (when (and (integerp x) (<= 0 x)) 182 (let ((*print-base* 36)) 183 (format nil "~(~a~)" x)))) 184 185 (defun parse36 (x) 186 (flet ((base36 (x) 187 (find x "0123456789abcdefghijklmnopqrstuvwxyz"))) 188 (when (and x (not (equal "" x)) (every #'base36 x)) 189 (parse-integer x :radix 36)))) 190 191 ;;(parse36 (pretty36 123456789)) 192 ;;(parse36 (pretty36 37)) 193 ;;(parse36 (pretty36 109)) 194 195 (defun generate-sid () 196 ;; (< (expt 36 12) (expt 2 64) (expt 36 13)) 197 (pretty36 198 #+nil(random #.(expt 36 13)) 199 (with-open-file (*standard-input* "/dev/urandom" 200 :element-type '(unsigned-byte 8)) 201 (rd 4)))) 202 203 (defun make-pool () 204 (let ((s (make-hash-table :test #'equal)) 205 (l (rw.concurrency:make-lock "pool ~s"))) 206 (lambda (create construct deconstruct) 207 (multiple-value-bind (sid aid *renv*) (funcall deconstruct) 208 (let ((aid2 (parse36 aid))) ;; number=action|string=resource 209 (when aid2 210 (setq aid aid2))) 211 (funcall 212 (rw.concurrency:using-lock 213 l 214 (lambda () 215 (maphash (lambda (k v) 216 (unless (funcall v t) 217 (remhash k s))) 218 s) 219 (let ((x (and sid aid (gethash sid s)))) 220 (if x 221 (lambda () (funcall x aid)) 222 (do () 223 ((not (gethash (setq sid (generate-sid)) s)) 224 (setf (gethash sid s) 225 (make-session sid create construct)) 226 (lambda () 227 (http-redirect 228 (funcall construct sid (pretty36 0) *renv*)))))))))))))) 229 230 (defparameter *pool* (make-pool)) 231 232 (defun draw (create construct deconstruct) 233 (funcall *pool* create construct deconstruct)) 234 235 (defun link (draw click &key style (enabled t) accesskey rel) 236 (flet ((%draw () 237 (if (functionp draw) (funcall draw) draw))) 238 (if enabled 239 `((:a 240 :href ,(funcall *click-link* click) 241 :style ,style 242 :accesskey ,accesskey 243 :rel ,rel) 244 ,(%draw)) 245 `((:span :style "color:gray") ,(%draw))))) 246 247 (defun input (set type value enabled editable style size maxlength) 248 `((:input 249 :name ,(when (and set enabled editable) (funcall *click-form* set)) 250 :type ,type 251 :value ,value 252 :disabled ,(unless enabled :disabled) 253 :readonly ,(unless editable :readonly) 254 :style ,style 255 :size ,size 256 :maxlength ,maxlength))) 257 258 (defun submit (label set &key (enabled t) style) 259 (input set "submit" label enabled t style nil nil)) 260 261 (defun yes () t) 262 (defun no ()) 263 (defun no1 (x) (declare (ignore x))) 264 265 (defun reset (label &key (enabled t) style) 266 (input 'no1 "reset" label enabled t style nil nil)) 267 268 (defun password (set &key (enabled t) (editable t) style) 269 (input set "password" nil enabled editable style nil nil)) 270 271 (defun entry (set text &key (enabled t) (editable t) style size maxlength) 272 (input set "text" text enabled editable style size maxlength)) 273 274 (defun file (set &key (enabled t) style size) 275 (input set "file" nil enabled t style size nil)) 276 277 (defun text (set text nrows ncols &key (enabled t) (editable t) style) 278 `((:textarea 279 :name ,(funcall *click-form* set) 280 :rows ,nrows 281 :cols ,ncols 282 :disabled ,(unless enabled :disabled) 283 :readonly ,(unless editable :readonly) 284 :style ,style) 285 ,text)) 286 287 (defun form (draw) 288 `((:form 289 :action ,(funcall *click-link* 'no) 290 :method "post" 291 :enctype "multipart/form-data" 292 :style "padding:0;margin:0;border:0") 293 ((:div :style "width:0;height:0;overflow:hidden") ,(submit nil 'no1)) 294 ,(if (functionp draw) (funcall draw) draw))) 295 296 (defun visible-widget (show draw) 297 (lambda () 298 (when (funcall show) 299 (funcall draw)))) 300 301 (defun popup-widget (show draw) 302 (visible-widget 303 show 304 (lambda () 305 `((:div :style (:style 306 :position :absolute 307 :background-color :white 308 :border "solid 1px" 309 :padding "0.5em")) 310 ((:div :style (:style :position :relative)) 311 ,(funcall draw)))))) 312 313 (defun screen-direction-combo-widget (popup selected click align) 314 (combo-widget 315 popup 316 selected 317 click 318 (list 'no 'no 'no 'no 'no 'no 'no 'no 'no) 319 (flet ((item2 (label &rest %align) 320 (combo-item2-widget label (apply align %align)))) 321 (list 322 (item2 "Top Left" :top :left) 323 (item2 "Top Center" :top :center) 324 (item2 "Top Right" :top :right) 325 (item2 "Center Left" :center :left) 326 (item2 "Center" :center :center) 327 (item2 "Center Right" :center :right) 328 (item2 "Bottom Left" :bottom :left) 329 (item2 "Bottom Center" :bottom :center) 330 (item2 "Bottom Right" :bottom :right))))) 331 332 (defun screen-direction-graphics-widget (popup selected click align) ;; TODO selected 333 (dropdown-widget 334 click 335 (lambda ()) 336 popup 337 (let ((n (flet ((item2 (label &rest %align) ;; TODO label as hint 338 (apply align %align))) 339 (list 340 (item2 "Top Left" :top :left) 341 (item2 "Top Center" :top :center) 342 (item2 "Top Right" :top :right) 343 (item2 "Center Left" :center :left) 344 (item2 "Center" :center :center) 345 (item2 "Center Right" :center :right) 346 (item2 "Bottom Left" :bottom :left) 347 (item2 "Bottom Center" :bottom :center) 348 (item2 "Bottom Right" :bottom :right))))) 349 (lambda () 350 `(:pre 351 ,@(loop 352 with y = n 353 ;;with s = (funcall selected) 354 for i from 0 355 for x across "X | X | X 356 --+---+-- 357 X | X | X 358 --+---+-- 359 X | X | X" 360 collect (cond 361 ;; ((= s i) 362 ;; `(:b (string x))) 363 ((char= #\X x) 364 (link (string x) 365 (let ((z (pop y))) 366 (lambda () (funcall z))))) 367 (t (string x))))))))) 368 369 (defun dialog-widget (show close draw1 draw2 &optional draw3) 370 (visible-widget 371 show 372 (let* ((halign :center) 373 (valign :center) 374 popup 375 (cw (flet ((align (v h) 376 (lambda () 377 (setq popup nil 378 halign h 379 valign v)))) 380 (screen-direction-graphics-widget ;;screen-direction-combo-widget 381 (lambda () popup) 382 (lambda () 4) 383 (lambda () (setq popup (not popup))) 384 #'align)))) 385 (lambda () 386 (let (#+nil(id1 (funcall *click-form* 'no1)) 387 #+nil(id2 (funcall *click-form* 'no1))) 388 `((:table :style (:style :position :fixed ;;:absolute 389 :left 0 390 :top 0 391 :width "100%" 392 :height "100%" 393 :padding 0 394 :margin 0 395 :border 0 396 :pointer-events "none")) 397 (:tr 398 ((:td :align ,halign :valign ,valign) 399 ((:table :style (:style :pointer-events "auto" 400 :border "solid 1px" 401 :background-color "#eef")) 402 ((:tr :style (:style :background-color "#dde" :padding "0.3em")) 403 (:td ,(funcall cw) 404 ,(funcall draw1) 405 ((:span :style "font-family:monospace") 406 " " 407 ,(when close (link "X" close)))) 408 #+nil 409 (:td ((:span :style "font-family:monospace") 410 ,(link "X" close) 411 " ") 412 ,(funcall draw1) 413 ((:span :style "font-family:monospace") 414 " " 415 ,(link "L" (lambda () (setq halign :left))) 416 ,(link "C" (lambda () (setq halign :center))) 417 ,(link "R" (lambda () (setq halign :right))) 418 "-" 419 ,(link "T" (lambda () (setq valign :top))) 420 ,(link "C" (lambda () (setq valign :center))) 421 ,(link "B" (lambda () (setq valign :bottom)))))) 422 (:tr (:td ,(funcall draw2))) 423 , (when draw3 424 `(:tr (:td ,(funcall draw3)))))))))))) 425 #+nil 426 (visible-widget 427 show 428 (lambda () 429 (let (#+nil(id1 (funcall *click-form* 'no1)) 430 #+nil(id2 (funcall *click-form* 'no1))) 431 `((:div :style (:style :position :absolute :left 0 :top 0)) 432 ((:div :style (:style :position :relative)) 433 ((:div 434 ;;:id ,id1 435 :style (:style 436 ;;:position "absolute" 437 :border "solid 1px" 438 :background-color "#eef")) 439 ((:div 440 ;;:id ,id2 441 :style (:style :background-color "#dde" :padding "0.3em")) 442 ,(funcall draw1)) 443 ((:div :style (:style :padding "0.5em")) ,(funcall draw2)) 444 , (when draw3 445 `((:div :style (:style :padding "0.5em")) 446 ,(funcall draw3)))) 447 #+nil 448 ((:script :type "text/javascript") 449 "draggable(w('" ,id1 "'),w('" ,id2 "'),dragDialog);"))))))) 450 451 (defun combo-item1-widget (label &key style) 452 (lambda () 453 (if style 454 `((:span :style (:style :padding "0.1em" ,@style)) ,label) 455 label))) 456 457 (defun combo-item2-widget (label click &key style1 style2) 458 (lambda () 459 `((:td :style (:style ,@style1)) 460 ,(link label click :style `(:style ,@style2))) 461 #+nil 462 `((:li :style (:style :padding "0.1em" ,@style1)) 463 ,(link label click :style `(:style ,@style2))))) 464 465 (defun dropdown-widget (click label popup draw) 466 (let ((pw (popup-widget popup draw))) 467 (lambda () 468 `(:span ,(link "^" click) " " ,(funcall label) ,(funcall pw))))) 469 470 (defun combo-widget (popup selected click items1 items2 &optional (ncols 1)) 471 (dropdown-widget 472 click 473 (lambda () (funcall (nth (funcall selected) items1))) 474 popup 475 (lambda () 476 `(:table 477 ,@ (ecase ncols 478 (1 (loop 479 for x in items2 480 collect `(:tr ,(funcall x)))) 481 (2 (loop 482 for (x y) on items2 by #'cddr 483 collect `(:tr ,(funcall x) ,(funcall y)))))) 484 #+nil 485 `((:ul :style (:style 486 :top 0 487 :left 0 488 :list-style :none 489 :margin 0 490 :padding 0)) 491 ,@(mapcar #'funcall items2))))) 492 493 (defun checkbox (selected click) 494 `((:span :style (:style :font-family :monospace)) 495 "[" 496 ,(link (lambda () 497 (if (if (functionp selected) (funcall selected) selected) "X" "-")) 498 click) 499 "]")) 500 501 (defun radio (selected click) 502 `((:span :style (:style :font-family :monospace)) 503 "(" 504 ,(link (lambda () (if (funcall selected) "o" "-")) click) 505 ")")) 506 507 (defun spin (get set min max &key enabled) 508 (let ((x (funcall get))) 509 #+nil 510 `((:input 511 :name ,(funcall *click-form* set) 512 :type "number" 513 :min ,min 514 :max ,max 515 :value ,x 516 ;;:disabled ,(unless enabled :disabled) 517 ;;:readonly ,(unless editable :readonly) 518 ;;:style ,style 519 ;;:size ,size 520 ;;:maxlength ,maxlength 521 )) 522 `(:span 523 , (let ((n (max (length (princ-to-string min)) 524 (length (princ-to-string max))))) 525 (entry (lambda (x) 526 (let ((y (parse-nat0 x))) 527 (when y 528 (funcall set (max min (min max y)))))) 529 x 530 :enabled enabled 531 :style "text-align:right" 532 :size n 533 :maxlength n)) 534 " " 535 ,(if enabled 536 (link "▼" (lambda () (funcall set (max min (1- x))))) 537 "▼") 538 " " 539 ,(if enabled 540 (link "▲" (lambda () (funcall set (min max (1+ x))))) 541 "▲")))) 542 543 (defun hbox-widget (children &optional separator) 544 (if separator 545 (lambda () 546 `(:span 547 ,@(loop 548 for x in children 549 for i from 0 550 appending (if (plusp i) 551 (list (if (eq t separator) " " separator) 552 (funcall x)) 553 (list (funcall x)))))) 554 (lambda () 555 `(:table ;;(:table :border 0 :cellpadding 0 :cellspacing 0) 556 (:tr ,@(mapcar (lambda (x) `(:td ,(funcall x))) children)))))) 557 558 (defun vbox-widget (children &optional div) 559 (if div 560 (lambda () 561 `(:div 562 ,@(mapcar (lambda (x) `(:div ,(funcall x))) children))) 563 (lambda () 564 `(:table ;;(:table :border 0 :cellpadding 0 :cellspacing 0) 565 ,@(mapcar (lambda (x) `(:tr (:td ,(funcall x)))) children))))) 566 567 (defun choice-widget (selected click choices &optional horizontal) 568 (let* ((radios (loop 569 for c in choices 570 for i from 0 571 collect (let ((i i)) 572 (lambda () 573 (radio 574 (lambda () (= i (funcall selected))) 575 (lambda () (funcall click i))))))) 576 (children (mapcar (lambda (r c) (hbox-widget (list r c) t)) 577 radios 578 choices))) 579 (if horizontal 580 (hbox-widget children) 581 (vbox-widget children)))) 582 583 (defun calendar-widget (year month &key (first-weekday 0) (show-weeks t)) 584 (lambda () 585 (let ((weeks (when show-weeks (rw.calendar::week-generator year month)))) 586 `((:table :style "font-family:monospace") 587 (:tr 588 ,@(when weeks '((:td ""))) 589 ((:td :colspan 3 :align "center") 590 , (let ((y year) 591 (m (1- month))) 592 (when (< m 1) 593 (decf y) 594 (setq m 12)) 595 (link "<" (lambda () (setq year y month m)))) 596 " " ,(rw.calendar::pretty-month month) " " 597 , (let ((y year) 598 (m (1+ month))) 599 (when (< 12 m) 600 (incf y) 601 (setq m 1)) 602 (link ">" (lambda () (setq year y month m))))) 603 ((:td :align "center") ,(link "@" (lambda ()))) 604 ((:td :colspan 3 :align "center") 605 , (let ((y (1- year))) 606 (link "<" (lambda () (setq year y)))) 607 " " ,year " " 608 , (let ((y (1+ year))) 609 (link ">" (lambda () (setq year y)))))) 610 (:tr 611 ,@(when weeks '((:td " "))) 612 ,@(loop 613 with g = (rw.calendar::weekday-generator first-weekday) 614 for i from 0 below 7 615 for n = (funcall g) 616 collect `((:td :style 617 (:style :color ,(when (rw.calendar::weekend n) "red"))) 618 ,(rw.calendar::pretty-day n)))) 619 ,@(loop 620 with g = (rw.calendar::day-generator year month first-weekday) 621 for i from 0 below 6 622 collect `(:tr 623 ,@(when weeks `(((:td :align "right") ,(funcall weeks)))) 624 ,@(loop 625 for j from 0 below 7 626 for d = (funcall g) 627 collect `((:td :align "right") 628 ,(if d 629 (link d (lambda ())) 630 "")))))))))