;;;;; Copyright (c) 2010-2013, Martin Loetzsch ;;;;; All rights reserved. ;;;;; Redistribution and use in source and binary forms, with or ;;;;; without modification, are permitted provided that the following ;;;;; conditions are met: ;;;;; Redistributions of source code must retain the above copyright ;;;;; notice, this list of conditions and the following disclaimer. ;;;;; Redistributions in binary form must reproduce the above ;;;;; copyright notice, this list of conditions and the following ;;;;; disclaimer in the documentation and/or other materials provided ;;;;; with the distribution. ;;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, ;;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF ;;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR ;;;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF ;;;;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED ;;;;; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ;;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING ;;;;; IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF ;;;;; THE POSSIBILITY OF SUCH DAMAGE. (cl:defpackage :ht-simple-ajax (:use :common-lisp :hunchentoot) (:export :ajax-processor :defun-ajax :create-ajax-dispatcher :generate-prologue)) (in-package :ht-simple-ajax) (defclass ajax-processor () ((lisp-fns :accessor lisp-fns :initform (make-hash-table :test #'equal) :type hash-table :documentation "Maps the symbol names of the exported functions to their symbols") (js-fns :accessor js-fns :initform (make-hash-table :test #'equal) :type hash-table :documentation "Maps the symbol names of the exported functions to a javascript code that can call the function from within the client page") (server-uri :initarg :server-uri :initform "/ajax" :accessor server-uri :type string :documentation "The uri which is used to handle ajax request") (content-type :initarg :content-type :type string :accessor content-type :initform "text/xml; charset=\"utf-8\"" :documentation "The http content type that is sent with each response") (reply-external-format :initarg :reply-external-format :type flexi-streams::external-format :accessor reply-external-format :initform hunchentoot::+utf-8+ :documentation "The format for the character output stream")) (:documentation "Maintains a list of lisp function that can be called from a client page.")) (defun create-ajax-dispatcher (processor) "Creates a hunchentoot dispatcher for an ajax processor" (create-prefix-dispatcher (server-uri processor) #'(lambda () (call-lisp-function processor)))) (defun make-js-symbol (symbol) "helper function for making 'foo_bar_' out of 'foo-bar?' " (loop with string = (string-downcase symbol) for c across "?-<>" do (setf string (substitute #\_ c string)) finally (return string))) (defmacro defun-ajax (name params (processor) &body body) "Declares a defun that can be called from a client page. Example: (defun-ajax func1 (arg1 arg2) (*ajax-processor*) (do-stuff))" (let ((js-fn (format nil " function ~a (~{~a, ~}callback) { ajax_call('~a', callback, ~2:*[~{~a~^, ~}]); }" (concatenate 'string "ajax_" (make-js-symbol name)) (mapcar #'make-js-symbol params) (symbol-name name)))) `(progn (defun ,name ,params ,@body) (setf (gethash (symbol-name ',name) (lisp-fns ,processor)) ',name) (setf (gethash (symbol-name ',name) (js-fns ,processor)) ',js-fn)))) (defun generate-prologue (processor) "Creates a html element that contains all the client-side javascript code for the ajax communication. Include this script in the of each html page" (apply #'concatenate 'string `(""))) (defun call-lisp-function (processor) "This is called from hunchentoot on each ajax request. It parses the parameters from the http request, calls the lisp function and returns the response." (let* ((fn-name (string-trim "/" (subseq (script-name* *request*) (length (server-uri processor))))) (fn (gethash fn-name (lisp-fns processor))) (args (mapcar #'cdr (get-parameters* *request*)))) (unless fn (error "Error in call-lisp-function: no such function: ~A" fn-name)) (setf (reply-external-format*) (reply-external-format processor)) (setf (content-type*) (content-type processor)) (no-cache) (concatenate 'string " " (apply fn args) "")))