/src/ajax-render.lisp
Lisp | 575 lines | 340 code | 83 blank | 152 comment | 2 complexity | a33fb9e89a1d49f83110ae7ecabf6df3 MD5 | raw file
1(in-package :wu) 2 3;;; +=========================================================================+ 4;;; | Copyright (c) 2009, 2010 Mike Travers and CollabRx, Inc | 5;;; | | 6;;; | Released under the MIT Open Source License | 7;;; | http://www.opensource.org/licenses/mit-license.php | 8;;; | | 9;;; | Permission is hereby granted, free of charge, to any person obtaining | 10;;; | a copy of this software and associated documentation files (the | 11;;; | "Software"), to deal in the Software without restriction, including | 12;;; | without limitation the rights to use, copy, modify, merge, publish, | 13;;; | distribute, sublicense, and/or sell copies of the Software, and to | 14;;; | permit persons to whom the Software is furnished to do so, subject to | 15;;; | the following conditions: | 16;;; | | 17;;; | The above copyright notice and this permission notice shall be included | 18;;; | in all copies or substantial portions of the Software. | 19;;; | | 20;;; | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | 21;;; | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | 22;;; | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. | 23;;; | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY | 24;;; | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, | 25;;; | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE | 26;;; | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. | 27;;; +=========================================================================+ 28 29;;; Author: Mike Travers 30 31#| 32Tools for rendering Ajax updates, based on the similar functionality found in Rails see: 33 http://api.rubyonrails.org/classes/ActionView/Helpers/PrototypeHelper/JavaScriptGenerator/GeneratorMethods.html 34 35Note: to use these, you need to have prototype and (for some operations) scriptaculous. 36Here's an easy way to do include them: 37 (javascript-includes "prototype.js" "effects.js" "dragdrop.js") 38 39For examples, see the test and examples directories. 40 41Available render-update operations, hopefully mostly self-explanatory. See the Rails and Prototype documentation for details. 42 43(:insert <position> <html>) 44(:update <id> <html>) 45(:replace <id> <html>) 46(:remove <id>) 47(:hide <id>) 48(:show <id>) 49(:toggle <id>) 50;; +++ :add-class :remove-class, addClassName(<elt>, <name>)... 51 52(:draggable <id> <options>) 53(:drop-target <id> <options>) 54 55(:js <javascript>) 56 57(:redirect <url>) 58(:navigate <url>) 59 60(:reload) 61(:delay <seconds> <other-forms>) 62(:alert <msg>) 63 64(:visual_effect <effect-name> <id> <options>) 65 66Here's an example of combining render-update operations: 67 68(defun render-animated-delete (id &optional (factor 1)) 69 (render-update 70 (:visual-effect :blind-up id :duration (* factor 0.25)) 71 (:visual-effect :fade id :duration (* factor 0.5)) 72 (:delay (* factor .5) 73 (:remove id)))) 74 75|# 76 77;;; Define an update method handler 78 79(defmacro define-render-update (type args &body body) 80 `(eval-when (:compile-toplevel :load-toplevel :execute) 81 (setf (get ,type :renderer) 82 (named-lambda ,type ,args 83 ,@body)))) 84 85(define-render-update :update (elt htmlspec) 86 `(let ((html 87 (with-output-to-string (s) 88 (let ((*html-stream* s)) 89 (html ,htmlspec))))) 90 (format *html-stream* "~%Element.update('~A', ~A);" ,elt (json:encode-json-to-string html)))) 91 92(define-render-update :replace (elt htmlspec) 93 `(let ((html 94 (with-output-to-string (s) 95 (let ((*html-stream* s)) 96 (html ,htmlspec))))) 97 ;; This works better with FireFox, not sure why... 98 ;; actually it doesn't, it leaves an extra DIV, so this is not right... 99; (format *html-stream* "~%document.getElementById('~a').innerHTML=~A;" ,elt (json:encode-json-to-string html)) 100 (format *html-stream* "~%Element.replace('~A', ~A);" ,elt (json:encode-json-to-string html)) 101;;; another alternate form 102; (format *html-stream* "~%$('~A').replace(~A);" ,elt (json:encode-json-to-string html)) 103 )) 104 105(define-render-update :insert (position elt htmlspec) 106 `(let ((html 107 (with-output-to-string (s) 108 (let ((*html-stream* s)) 109 (html ,htmlspec))))) 110 (format *html-stream* "~%Element.insert('~A',{~A: ~A});" ,elt (string-downcase (string ,position)) (json:encode-json-to-string html)))) 111 112(defmacro define-render-element-operation (keyword &optional (func (string-downcase (string keyword)))) 113 `(define-render-update ,keyword (elt) 114 `(format *html-stream* "~%Element.~A('~A');" ,,func ,elt))) 115 116(define-render-element-operation :hide) 117(define-render-element-operation :show) 118(define-render-element-operation :toggle) 119(define-render-element-operation :remove) 120 121(defun escape-single-quotes (string) 122 (mt:string-replace string "'" "\\'")) 123 124;;; pretty simple! 125(define-render-update :js (string) 126 `(progn (terpri *html-stream*) 127 (awhen ,string (write-string it *html-stream*)))) 128 129;;; A script that gets inserted after the normal updates 130(define-render-update :post-js (string) 131 (render-script-later string)) 132 133(define-render-update :redirect (url) 134 `(format *html-stream* "~%window.location.replace('~A');" ,url)) 135 136;;; "redirect" and "navigate to new page" have different behaviors re browser history 137(define-render-update :navigate (url) 138 `(format *html-stream* "~%window.location.href = '~A';" ,url)) 139 140(define-render-update :popup (url &optional (name "_popup") (width 300) (height 300)) 141 `(format *html-stream* "~%window.open('~A', '~A', 'width=~A,height=~A');" ,url ,name ,width ,height)) 142 143(define-render-update :reload () 144 `(format *html-stream* "~%window.location.reload();")) 145 146(define-render-update :delay (seconds &rest other-forms) 147 `(progn 148 (format *html-stream* "setTimeout(function() {") 149 ,@(mapcar #'(lambda (clause) 150 (apply (or (get (car clause) :renderer) 151 (error "Don't know how to do operation ~A" (car clause))) 152 (cdr clause))) 153 other-forms) 154 (format *html-stream* "}, ~A)" (* ,seconds 1000)))) 155 156(define-render-update :visual-effect (effect elt &rest options) 157 `(format *html-stream* "~%Effect.~A('~A', ~A);" (camel-case (string ,effect)) ,elt (json-options (list ,@options)))) 158 159(define-render-update :alert (message) 160 `(format *html-stream* "~%alert('~A');" (escape-single-quotes ,message))) 161 162;;; dynamically bound to allow some things to change their behaviors. 163(defvar *within-render-update* nil) 164 165;;; Mechanism for including js in HTML that might be an Ajax update or not. 166(defvar *render-update-scripts* nil) 167 168(defvar *render-debugging* nil) 169 170(defmacro render-debug (msg) 171 `(when *render-debugging* 172 (format t "~%render-debug: ~A" ,msg))) 173 174;;; Wrap this around anything that does javascript updating. 175;;; Saner version (duplicates body, might want to fix that with a closure or something +++) 176(defmacro with-render-update (&body body) 177 `(if *within-render-update* 178 (progn ,@body) 179 (let ((*render-update-scripts* nil) 180 (*within-render-update* t)) 181 ,@body 182 (render-update-scripts)))) 183 184(defun render-script-later (script) 185 (push-end script *render-update-scripts*)) 186 187;;; Render 188(defun render-update-scripts () 189 (dolist (script *render-update-scripts*) 190 (render-debug (list 'script-out script)) 191 (write-string script *html-stream*))) 192 193(defmacro render-update (&body clauses) 194 `(with-render-update 195 ,@(mapcar #'(lambda (clause) 196 (apply (or (get (car clause) :renderer) 197 (error "Don't know how to do operation ~A" (car clause))) 198 (cdr clause))) 199 clauses))) 200 201 202;;; Like render-update, but for use within HTML blocks. 203;;; Will either render scripts in script element as part of a page, or (if done inside an render-update) collect them for 204;;; appending to the update. 205(defmacro render-scripts (&body clauses) 206 `(if *within-render-update* 207 (render-script-later (html-string 208 (render-update ,@clauses))) 209 (html ((:script :type "text/javascript") 210 (render-debug "rendering <script> elt") 211 (render-update ,@clauses))) 212 )) 213 214;;; Version of above that takes raw script rather than render-update clauses 215(defmacro render-script (script) 216 `(if *within-render-update* 217 (render-script-later ,script) 218 (html ((:script :type "text/javascript") 219 (render-debug "rendering <script> elt") 220 :newline 221 (:princ ,script)) 222 ))) 223 224(defun html-escape-string (string) 225 (with-output-to-string (stream) 226 (net.html.generator::emit-safe stream string))) 227 228;; Amazingly, FireFox will generate close tags for lisp objects 229;; printed in pointy brackets, but then we *are* lying about the 230;; content type. 231;; This is not real JSON escaping....also not very efficient 232(defun clean-upload-js-string (string) 233 (string-replace 234 (string-replace string ">" ">") 235 "<" "<") 236 ) 237 238;;; Not very efficient 239(defun clean-js-string (string) 240 (string-replace 241 (string-replace 242 (string-replace string (string #\Newline) "\\n") 243 "\"" "\\\"") 244 "'" "\\'")) 245 246 247(defvar *multipart-request*) 248(defvar *ajax-request* nil) 249 250;; If the client performs a file upload, an HTML form is used and a page of type text/html must be returned 251;;; +++ why is this a macro? 252(defmacro multipart? (req) 253 `(let ((header (header-slot-value ,req :content-type))) 254 (and header 255 (string= (subseq header 0 (min (length header) (length "multipart/form-data"))) 256 "multipart/form-data")))) 257 258 259;;;; :::::::::::::::::::::::::::::::: Ajax-continuation and friends :::::::::::::::::::::::::::::::: 260 261#| 262 263publish-ajax-update, publish-ajax-func, and ajax-continuation all do similar things: that is, 264they publish a temporary URL that, upon receipt at server, executes BODY. 265 266- publish-ajax-update is the lowest level 267 268- publish-ajax-func wraps publish-ajax-update, but also implements argument processing (that is, it 269 will convert request parameters into variables bound around BODY). 270 271- ajax-continuation wraps publish-ajax-func, and in adddition handles automatically generating the 272 URL and decomissioning it when done. 273 274Options 275 276:SESSION : NIL if no session management, T for session management, or the name of login handling 277 procedure if login is required. The procedure takes req and ent and is responsible for 278 redirecting to a login page. 279 280:PRE-RESPONSE is a list of forms executed before the response (so things that affect cookie session 281 state should go there) 282 283:KEEP (ajax-continuation) T if continuation should be kept around after use (that is, it is something 284 that may be called more than once). 285 286:ARGS (ajax-continuation) a list of arguments to be bound around BODY, and should be supplied in the POST. 287 288:CONTENT-TYPE 289:TIMEOUT (specifiy a timeout, looks like this is not actually implemented) 290 291 292|# 293 294(defmacro publish-ajax-update (path-or-options &body body) 295 (let* ((path (if (listp path-or-options) 296 (findprop :path path-or-options) 297 path-or-options)) 298 (options (if (listp path-or-options) path-or-options)) 299 (content-type (and (listp path-or-options) (findprop :content-type path-or-options))) 300 (session (aif (and (listp path-or-options) (member :session path-or-options)) 301 (cadr it) 302 t)) ;defaults to t 303 (pre-response (and (listp path-or-options) (findprop :pre-response path-or-options))) 304 (login-handler (aif (and (listp path-or-options) (member :login-handler path-or-options)) 305 (cadr it)))) 306 (setf options (delete-keyword-args '(:path :session :pre-response) options)) 307 `(publish-temporarily ,path 308 :function #'(lambda (req ent) 309 (let* ((*multipart-request* (multipart? req)) 310 (*ajax-request* req) 311 ;; +++ not sure what this condition on *multipart-request* was for, seems wrong 312 (content-type ,(or content-type `(if *multipart-request* "text/html" "text/javascript")))) 313 (,@(if session 314 `(with-session (req ent ,@(if login-handler `(:login-handler ,login-handler)))) 315 '(progn)) 316 (with-http-response-and-body (req ent :content-type content-type) 317 (with-ajax-error-handler (,path) 318 (with-render-update 319 ,@body 320 ))))) 321 ) 322 ,@options 323 ))) 324 325(defmacro publish-ajax-func (path-or-options args &rest body) 326 `(publish-ajax-update ,path-or-options 327 (let (,@(mapcar #'(lambda (arg) 328 `(,arg (request-query-value ',(smart-string (string arg)) req))) 329 args)) 330 ,@body))) 331 332(defvar *ajax-counter* 0) 333 334(defmacro ajax-continuation ((&key args keep (content-type "text/javascript") (session nil session-spec?) name login-handler timeout) &body body) 335 `(let ((fname (string+ "/ajax/" ,(or name "g") "/" (fast-string (incf *ajax-counter*))))) 336 (publish-ajax-func (:path fname 337 ,@(if content-type `(:content-type ,content-type)) 338 ,@(if session-spec? `(:session ,session)) 339 ,@(if login-handler `(:login-handler ,login-handler)) 340 ,@(if timeout `(:timeout ,timeout))) 341 ,args 342 ,@body 343 ,(unless keep 344 '(unpublish-path fname))) 345 fname)) 346 347 348 349;;; Inexplicably not in aserve 350;;; Later versions of aserve have a non-functional function called unpublish, so we give this a different name 351(defun unpublish-path (path) 352 (net.aserve::unpublish-entity (net.aserve::find-locator :exact *wserver*) path nil nil)) 353 354(defun publish-temporarily (path &rest args) 355 (apply 'publish :path path args) 356 (set-responder-timeout path)) 357 358;; could keep this sorted I supposed 359(defvar *responder-timeouts* nil) 360 361(defun set-responder-timeout (path &optional (time (+ (now) *default-responder-timeout*))) 362 (push (list time path) *responder-timeouts*)) 363 364(publish-prefix :prefix "/ajax/" 365 :function 'ajax-timeout) 366 367(defun ajax-timeout (req ent) 368 (with-http-response-and-body (req ent :content-type "text/javascript") 369 (render-update 370 (:alert "Command expired. Try reloading the page")))) 371 372(defun do-responder-timeouts () 373 (let* ((now (get-universal-time)) 374 (expired (filter #'(lambda (item) 375 (< (car item) now)) 376 *responder-timeouts*))) 377 (dolist (item expired) 378 (unpublish-path (cadr item))) 379 (setf *responder-timeouts* (nset-difference *responder-timeouts* expired)))) 380 381#-:SBCL 382(eval-when (:load-toplevel :execute) 383 (in-background "Responder timeout" 384 (loop 385 (sleep (floor *default-responder-timeout* 2)) 386 (do-responder-timeouts)))) 387 388 389;;; Drag/drop 390 391;;; See here for description of options: http://wiki.github.com/madrobby/scriptaculous/draggable 392;;; to make this useful, need patched cl-json that can do :raw strings. 393 394(define-render-update :draggable (elt &rest options) 395 `(format *html-stream* "~%new Draggable('~A', ~A);" 396 ,elt 397 (json-options (list ,@options)))) 398 399;;; Define an entire CSS class as draggable. 400;;; uses a local extension to scriptaculous. Does not apply to elements or classes added after the fact, a serious limitation. 401(define-render-update :draggable-class (class &rest options) 402 `(format *html-stream* "~%Draggable.addClass('~A', null, ~A);" 403 ,class 404 (json-options (list ,@options)))) 405 406;;; options are as specified by scriptaculous, see http://wiki.github.com/madrobby/scriptaculous/droppables 407;;; Particularly useful: 408;;; :accept <css class> or list of classes -- specifies what can be dropped here. 409;;; :|onDrop| `(:raw "function (elt) {...}") -- call the function when a drop occurs 410(define-render-update :drop-target (elt &rest options) 411 `(format *html-stream* "~%Droppables.add('~A', ~A);" 412 ,elt 413 (json-options (list ,@options)))) 414 415;;; turn keywords (:k1 v1 :k2 v2 ...) into CL-JSON 416(defun json-options-transform (options) 417 (do ((rest options (cddr rest)) 418 (result nil)) 419 ((null rest) 420 (nreverse result)) 421 (push (cons (smart-string (car rest)) (cadr rest)) 422 result))) 423 424;; as above but produce JSON string 425(defun json-options (options) 426 (json:encode-json-to-string 427 (json-options-transform options))) 428 429;;; UPCASE turned to downcase, mixed case is left alone. Needs a better name 430(defun smart-string (k) 431 (let ((s (string k))) 432 (if (string-upcase? s) 433 (string-downcase s) 434 s))) 435 436(defun string-upcase? (s) 437 (every #'(lambda (c) 438 (or (not (alpha-char-p c)) 439 (upper-case-p c))) 440 s)) 441 442;;; Equivalent of link_to_remote etc. Could take more options. 443;;; We can now deal with arbitrary html-options, so regularize the calling sequence of these... 444 445;;; default is :princ rather than :princ-safe to allow image tags in text. 446;;; Should be rethought, maybe this should be a macro that wraps arbitrary html gen. 447(defun link-to-function (text js &key html-options safe?) 448 (html 449 ((:a :href "#" :onclick js :do* html-options) 450 (if safe? 451 (html (:princ-safe text)) 452 (html (:princ text))))) ) 453 454(defun button-to-function (text js &key html-options) 455 (html 456 ((:input :type "button" :value text :onclick js :do* html-options)))) 457 458(defun link-to-remote (text url &rest remote-function-options &key html-options &allow-other-keys) 459 (link-to-function text (apply #'remote-function url (delete-keyword-args '(:html-options) remote-function-options)) 460 :html-options html-options)) 461 462(defun button-to-remote (text url &rest remote-function-options &key html-options &allow-other-keys) 463 (button-to-function text (apply #'remote-function url (delete-keyword-args '(:html-options) remote-function-options)) 464 :html-options html-options)) 465 466(defun checkbox-to-function (text js &key html-options) 467 (html 468 ((:input :type "checkbox" :onclick js :do* html-options)) 469 (:princ " ") 470 (:princ-safe (or text "")) 471 )) 472 473;;; +++ SBCL sniffs at having &optional and &key in the same arglist, and maybe it should be changed 474;;; +++ copy params, class keyword functionality to link-to-remote, button-to-remote, etc 475(defun checkbox-to-remote (text url &optional checked? &rest remote-function-options &key params (id (string (gensym "check"))) class html-options &allow-other-keys) 476 (checkbox-to-function 477 text 478 (apply #'remote-function url :in-function? nil :params `(:checked (:raw ,(format nil "$('~A').checked" id)) ,@params) (delete-keyword-args '(:html-options :id :class) remote-function-options)) 479 :html-options 480 `(:id ,id ,@(if class `(:class ,class)) ,@(if checked? '(:checked "true")) ,@html-options))) 481 482(defun radio-to-remote (text url &optional checked? &rest remote-function-options &key html-options &allow-other-keys) 483 (html 484 ((:input :type :radio :if* checked? :checked "true" :onclick (apply #'remote-function url (delete-keyword-args '(:html-options) remote-function-options)) 485 :do* html-options) 486 (:princ " ") 487 (:princ-safe (or text "")) 488 ))) 489 490(defun goto-url-function (url) 491 (format nil "~%window.location.href = '~A';" url)) 492 493(defvar *uploader-html* 494 (concatenate 'string 495 "<div id='~a'></div>" 496 "<script TYPE='text/javascript'>make_uploader('~a', '~a', '~a', ~a);</script>" 497 )) 498 499(defparameter *file-field-name* "Data") 500 501(defun uploader (id url &optional isDrugrank) 502 (format nil *uploader-html* id id url *file-field-name* (if isDrugrank "true" "false")) 503 ) 504 505;;; Note: response content type of text/javascript determines whether response is evaled or not 506(defun remote-function (url &key form params (in-function? t) confirm before after spinner 507 success failure complete eval-scripts? stop-propagation? 508 updater? periodic?) 509 #.(doc 510 "Generate a remote function (javascript Ajax call)" 511 " ex: (remote-function \"/new-chunk\" :params `(:user ,user :type (:raw ,(format nil \"$(~A).value\" selector-id))))" 512 " returns:" 513 " new Ajax.Request('/new-chunk', {\"asynchronous\":true,\"parameters\":{\"user\":\"mt\",\"type\":$(selector23).value}}); return false;" 514 ":form If t, serialize the surrounding form; if a string serialise the form with that name; else use params" 515 ":params List of (:key1 value1 ...), ignored if :form is t" 516 ":confirm Ask user for confirmation first (value is the message)" 517 ":complete Javascript to execute when action completes" 518 ":success as :complete, but on success only" 519 ":failure as :complete, but on failure only" 520 ":before Javascript to run before the Ajax request" 521 ":after Javascript to run after the Ajax request" 522 ":spinner The ID of an elt, a spinner will be inserted after the elt before the Ajax request and removed when completed" 523 ":in-function? " 524 ":eval-scripts? " ;;; +++ only valid for Ajax.Update object? 525 ":stop-propagation? Stop propagation of events to parents. Forces :in-function? to be nil" 526 ":updater? Make an Ajax.Updater object rather than an Ajax.Request; value is dom id of item to be updated" 527 ":periodic? Make an Ajax.PeriodicalUpdater, updater? must be non-nil" 528 ) 529 (when stop-propagation? 530 (setq in-function? nil)) ;incompatible, at least for now. 531 (when spinner 532 (let ((spin-js (format nil "add_spinner('~A');" spinner)) 533 (nospin-js (format nil "remove_spinner('~A');" spinner))) 534 (setf before (if before 535 (string+ before spin-js) 536 spin-js)) 537 (setf complete (if complete 538 (string+ nospin-js complete) 539 nospin-js)))) 540 (let* ((options 541 `(:asynchronous t 542 :parameters ,(if form 543 `(:raw ,(format nil "Form.serialize(~A)" 544 (if (stringp form) 545 (format nil "document.getElementById('~A')" form) 546 "this"))) 547 (json-options-transform params)) 548 ,@(if complete `("onComplete" (:raw ,(format nil "function(request){~A}" complete)))) 549 ,@(if success `("onSuccess" (:raw ,(format nil "function(request){~A}" success)))) 550 ,@(if failure `("onFailure" (:raw ,(format nil "function(request){~A}" failure)))) 551 ,@(if eval-scripts? `("evalScripts" t)) 552 )) 553 (result 554 (cond (periodic? 555 (assert updater?) 556 (setf options (append `(:frequency ,periodic?) options)) 557 (format nil "new Ajax.PeriodicalUpdater('~A', '~A', ~A);" updater? url (json-options options))) 558 (updater? 559 (format nil "new Ajax.Updater('~A', '~A', ~A);" updater? url (json-options options))) 560 (t 561 (format nil "new Ajax.Request('~A', ~A);" url (json-options options)))))) 562 (when before (setf result (string+ before result))) 563 (when after (setf result (string+ result after))) 564 (when confirm (setf result (format nil "if (confirm('~A')) { ~A };" confirm result))) 565 (when stop-propagation? 566 (setf result (format nil "~A Event.stop(event);" result))) 567 (when in-function? 568 (setf result (string+ result "return false;"))) 569 result)) 570 571 572 573 574 575