PageRenderTime 52ms CodeModel.GetById 16ms app.highlight 28ms RepoModel.GetById 1ms app.codeStats 1ms

/src/ajax-render.lisp

http://github.com/mtravers/wuwei
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 ">" "&gt;")
235   "<" "&lt;")
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 "&nbsp;")
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 "&nbsp;")
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