From a5ffa02d4fc6cb11078a055a25e5b966ca247651 Mon Sep 17 00:00:00 2001 From: Andy Peterson Date: Thu, 9 Jun 2011 22:41:45 -0400 Subject: [PATCH] first commit --- License.txt | 20 +++ README.txt | 14 +++ demo-ht-simple-ajax.lisp | 128 ++++++++++++++++++++ demo.lisp | 129 ++++++++++++++++++++ package.lisp | 9 ++ smackjack.asd | 43 +++++++ smackjack.lisp | 254 +++++++++++++++++++++++++++++++++++++++ 7 files changed, 597 insertions(+) create mode 100644 License.txt create mode 100644 README.txt create mode 100644 demo-ht-simple-ajax.lisp create mode 100644 demo.lisp create mode 100644 package.lisp create mode 100644 smackjack.asd create mode 100644 smackjack.lisp diff --git a/License.txt b/License.txt new file mode 100644 index 0000000..55e40c7 --- /dev/null +++ b/License.txt @@ -0,0 +1,20 @@ +Copyright (c) 2011 Andrew Arvid Peterson +Portions Copyright (c) 2010, Martin Loetzsch (ht-simple-ajax) + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.txt b/README.txt new file mode 100644 index 0000000..8d62e4a --- /dev/null +++ b/README.txt @@ -0,0 +1,14 @@ +This is the stub README.txt for the "smackjack" project. + +Smackjack is small Ajax framework written in Common Lisp. +Currently runs under Hunchentoot web server but there are plans +to allow other web servers. It is a fork of ht-simple-ajax and +inspires to be a replacement to the unmaintained and out of date +ht-ajax. + +Differently than those two libraries, this one depends on parenscript +to generate client-side javascript and allows greater flexibility in +generated javascript. + +Current version is compatible with ht-simple-ajax but it lacks many features +of ht-ajax. diff --git a/demo-ht-simple-ajax.lisp b/demo-ht-simple-ajax.lisp new file mode 100644 index 0000000..455d589 --- /dev/null +++ b/demo-ht-simple-ajax.lisp @@ -0,0 +1,128 @@ +;;;;; Copyright (c) 2010, 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. + +;;;;; +;;;;; This file provides a brief demo of how to use smackjack compatible +;;;;; with ht-simple-ajax +;;;;; +;;;;; For more information, go to http://martin-loetzsch.de/ht-simple-ajax +;;;;; + +(asdf:operate 'asdf:load-op :smackjack) + +(in-package :smackjack) + + + +;;;;; First we create an ajax processor that will handle our function calls +(defparameter *ajax-processor* + (make-instance 'ht-simple-ajax-processor :server-uri "/ajax")) + + +;;;;; Now we can define a function that we want to call from a web +;;;;; page. This function will take 'name' as an argument and return a +;;;;; string with a greeting. +(defun-ajax say-hi (name) (*ajax-processor*) + (concatenate 'string "Hi " name ", nice to meet you.")) + + +;;;;; We can call this function from Lisp, for example if we want to +;;;;; test it: +(print (say-hi "Martin")) + + +;;;;; Next, we setup and start a hunchentoot web server: +(defparameter *my-server* + (start (make-instance 'acceptor :address "localhost" :port 8000))) + + +;;;;; We add our ajax processor to the hunchentoot dispatch table +(setq *dispatch-table* (list 'dispatch-easy-handlers + (create-ajax-dispatcher *ajax-processor*))) + + +;;;;; Now we can already call the function from a http client: +;;;;; $ curl localhost:8000/ajax/SAY-HI?name=Martin +;;;;; will return +;;;;; +;;;;; Hi Martin, nice to meet you. +;;;;; Alternatively, you can also paste the url above in a web browser + + +;;;;; To conveniently call our function from within javascript, the +;;;;; ajax processor can create a html script element with generated +;;;;; javascript functions for each Lisp function: +(print (generate-prologue *ajax-processor*)) + +;;;;; Together with some helper code, this will also create this: +;;;;; +;;;;; function ajax_say_hi (name, callback) { +;;;;; ajax_call('SAY-HI', callback, [name]); +;;;;; } +;;;;; +;;;;; 'name' is the parameter of our Lisp function (if there are +;;;;; multiple parameters, then they will also appear here). Callback +;;;;; is a function that will be asynchronously called when the +;;;;; response comes back from the web server. That function takes +;;;;; 1 argument, which is the xml DOM object of the response. + + +;;;;; Finally, we can put everything together and create a page that +;;;;; calls our function. For rendering html, we will use cl-who in +;;;;; this example (http://weitz.de/cl-who/). Note that smackjack +;;;;; can be used with any other template/ rendering system +(asdf:operate 'asdf:load-op :cl-who) +(use-package :cl-who) + +(define-easy-handler (main-page :uri "/") () + (with-html-output-to-string (*standard-output* nil :prologue t) + (:html :xmlns "http://www.w3.org/1999/xhtml" + (:head + (:title "smackjack demo") + (princ (generate-prologue *ajax-processor*)) + (:script :type "text/javascript" " +// will show the greeting in a message box +function callback(response) { + alert(response.firstChild.firstChild.nodeValue); +} + +// calls our Lisp function with the value of the text field +function sayHi() { + ajax_say_hi(document.getElementById('name').value, callback); +} +")) + (:body + (:p "Please enter your name: " + (:input :id "name" :type "text")) + (:p (:a :href "javascript:sayHi()" "Say Hi!")))))) + + +;;;;; Direct your web browser to http://localhost:8000 and try it out! + + diff --git a/demo.lisp b/demo.lisp new file mode 100644 index 0000000..acad128 --- /dev/null +++ b/demo.lisp @@ -0,0 +1,129 @@ +;;;;; Copyright (c) 2010, 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. + +;;;;; +;;;;; This file provides a brief demo of how to use ht-simple-ajax +;;;;; +;;;;; For more information, go to http://martin-loetzsch.de/ht-simple-ajax +;;;;; + +;;(asdf:operate 'asdf:load-op :smackjack) + +(in-package :smackjack) + + + +;;;;; First we create an ajax processor that will handle our function calls +(defparameter *ajax-processor* + (make-instance 'ajax-processor :server-uri "/ajax")) + + +;;;;; Now we can define a function that we want to call from a web +;;;;; page. This function will take 'name' as an argument and return a +;;;;; string with a greeting. +(defun-ajax say-hi (name) (*ajax-processor*) + (concatenate 'string "Hi " name ", nice to meet you.")) + + +;;;;; We can call this function from Lisp, for example if we want to +;;;;; test it: +(print (say-hi "Martin")) + + +;;;;; Next, we setup and start a hunchentoot web server: +(defparameter *my-server* + (start (make-instance 'acceptor :address "localhost" :port 8000))) + + +;;;;; We add our ajax processor to the hunchentoot dispatch table +(setq *dispatch-table* (list 'dispatch-easy-handlers + (create-ajax-dispatcher *ajax-processor*))) + + +;;;;; Now we can already call the function from a http client: +;;;;; $ curl localhost:8000/ajax/SAY-HI?name=Martin +;;;;; will return +;;;;; +;;;;; Hi Martin, nice to meet you. +;;;;; Alternatively, you can also paste the url above in a web browser + + +;;;;; To conveniently call our function from within javascript, the +;;;;; ajax processor can create a html script element with generated +;;;;; javascript functions for each Lisp function: +(print (generate-prologue *ajax-processor*)) + +;;;;; Together with some helper code, this will also create this: +;;;;; +;;;;; function ajax_say_hi (name, callback) { +;;;;; ajax_call('SAY-HI', callback, [name]); +;;;;; } +;;;;; +;;;;; 'name' is the parameter of our Lisp function (if there are +;;;;; multiple parameters, then they will also appear here). Callback +;;;;; is a function that will be asynchronously called when the +;;;;; response comes back from the web server. That function takes +;;;;; 1 argument, which is the xml DOM object of the response. + + +;;;;; Finally, we can put everything together and create a page that +;;;;; calls our function. For rendering html, we will use cl-who in +;;;;; this example (http://weitz.de/cl-who/). Note that smackjack +;;;;; can be used with any other template/ rendering system +(asdf:operate 'asdf:load-op :cl-who) +(use-package :cl-who) + +(define-easy-handler (main-page :uri "/") () + (with-html-output-to-string (*standard-output* nil :prologue t) + (:html :xmlns "http://www.w3.org/1999/xhtml" + (:head + (:title "smackjack demo") + (princ (generate-prologue *ajax-processor*)) + (:script :type "text/javascript" " +var saveResponse; +// will show the greeting in a message box +function callback(response) { + saveResponse = response; + alert(response.firstChild.firstChild.nodeValue); +} + +// calls our Lisp function with the value of the text field +function sayHi() { + smackjack.sayHi(document.getElementById('name').value, callback); +} +")) + (:body + (:p "Please enter your name: " + (:input :id "name" :type "text")) + (:p (:a :href "javascript:sayHi()" "Say Hi!")))))) + + +;;;;; Direct your web browser to http://localhost:8000 and try it out! + + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..cf1c5b3 --- /dev/null +++ b/package.lisp @@ -0,0 +1,9 @@ +;;;; package.lisp + +(defpackage #:smackjack + (:use #:cl #:hunchentoot #:parenscript #:alexandria) + (:shadowing-import-from #:parenscript :switch) + (:export :ajax-processor :ht-simple-ajax-processor + :defun-ajax + :create-ajax-dispatcher :generate-prologue)) + diff --git a/smackjack.asd b/smackjack.asd new file mode 100644 index 0000000..4517391 --- /dev/null +++ b/smackjack.asd @@ -0,0 +1,43 @@ +;;;; smackjack.asd + +(asdf:defsystem #:smackjack + :serial t + :depends-on (#:alexandria + #:hunchentoot + #:parenscript) + :components ((:file "package") + (:file "smackjack") + (:module "impl-dependent" + :components ((:file + #+lispworks + "lispworks" + + #+allegro + "acl" + + #+cmucl + "cmucl" + + #+sbcl + "sbcl" + + #+clisp + "clisp" + + #+ecl + "ecl" + + #+gcl + "gcl" + + #+abcl + "abcl" + + #+clozure-common-lisp + "clozure-cl" + + #+ccl + "ccl" + )) + :depends-on ("package")))) + diff --git a/smackjack.lisp b/smackjack.lisp new file mode 100644 index 0000000..0c1f9a2 --- /dev/null +++ b/smackjack.lisp @@ -0,0 +1,254 @@ + +;;;; smackjack.lisp + +(in-package #:smackjack) + +;;; "smackjack" goes here. Hacks and glory await! + +(defclass ajax-function () + ((name :reader name + :initarg :name + :type symbol + :documentation "symbol name of the lisp ajax function") + (parameters :reader parameters + :initarg :paramaters + :type list + :documentation "parameters of the lisp ajax function") + ) + ) + +(defclass ajax-processor () + ((ajax-functions + :accessor ajax-functions :initform (make-hash-table :test #'equal) + :type hash-table + :documentation "Maps the symbol names of the remoted functions to + their ajax-function object") + (ajax-namespace + :initarg :ajax-function-prefix :initform 'smackjack + :accessor ajax-namespace + :type symbol + :documentation "Create a namespace object for generated javascript code") + (ajax-functions-namespace-p + :initarg :ajax-functions-namespace-p :initform t + :accessor ajax-functions-namespace-p + :type boolean + :documentation "Place javascript functions corresponding + to lisp functions in the ajax-namespace") + (ajax-function-prefix + :initarg :ajax-function-prefix :initform nil + :accessor ajax-function-prefix + :type symbol + :documentation "Prefix for javascript functions corresponding + to lisp functions") + + (ht-simple-ajax-symbols-p ;; should be removed in the future. + :initarg :ht-simple-ajax-symbols-p + :accessor ht-simple-ajax-symbols-p + :initform nil + :type boolean + :documentation "use ht-simple-ajax symbol processor to generate + compatible ht-simple-ajax compatible code") + (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"))) + +(defclass ht-simple-ajax-processor (ajax-processor) + ((ajax-namespace :initform nil) + (ajax-functions-namespace-p :initform nil) + (ajax-function-prefix :initform 'ajax) + (ht-simple-ajax-symbols-p :initform t))) + +(defgeneric create-ajax-dispatcher (processor)) +(defmethod create-ajax-dispatcher ((processor ajax-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))) + +(defun make-ps-symbol (symbol) + (symbolicate (string-upcase (make-js-symbol symbol)))) + + + +(defgeneric remote-function-via-ajax (processor function-name)) +(defmethod remote-function-via-ajax ((processor ajax-processor) + function-name) + (setf (gethash (symbol-name function-name) (ajax-functions processor)) + (make-instance 'ajax-function :name function-name))) + + +(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))" + `(progn + (defun ,name ,params ,@body) + (remote-function-via-ajax ,processor ',name))) + +(defgeneric ajax-function-name (processor name)) +(defmethod ajax-function-name ((processor ajax-processor) name) + (let ((compat (ht-simple-ajax-symbols-p processor)) + (prefix (ajax-function-prefix processor))) + (funcall (if compat #'make-ps-symbol #'identity) + (if prefix + (symbolicate prefix '- name) + name)))) + +(defgeneric ajax-ps-function (processor name)) +(defmethod ajax-ps-function ((processor ajax-processor) name) + (let* ((namespace (ajax-namespace processor)) + (ajax-fns-in-ns (and namespace (ajax-functions-namespace-p processor))) + (ajax-name (ajax-function-name processor name)) + (ajax-params (mapcar (if (ht-simple-ajax-symbols-p processor) + #'make-ps-symbol + #'identity) + (arglist name))) + (ajax-call (if (and namespace (not ajax-fns-in-ns)) + `(@ ,namespace ajax-call) + 'ajax-call))) + `(defun ,ajax-name ,ajax-params + (,ajax-call ,(string name) callback (array ,@ajax-params))))) + +(defgeneric ps-fetch-uri (processor)) +(defmethod ps-fetch-uri ((processor ajax-processor)) + (declare (ignore processor)) + '(defun fetch-uri (uri callback) + (let ((request)) + (if -x-m-l-http-request + (setf request (new (funcall -x-m-l-http-request))) + (try + (setf request (new (-active-x-object "Msxml2.XMLHTTP"))) + (:catch (e) + (try + (setf request (new (-active-x-object "Microsoft.XMLHTTP"))) + (:catch (ee) + (setf request nil)))))) + (unless request + (alert "Browser couldn't make a request object.")) + (with-slots (open ready-state status response-x-m-l + onreadystatechange send) request + (funcall open "GET" uri t) + (setf onreadystatechange + (lambda () + (when (/= 4 ready-state) + (return)) + (if (or (and (>= status 200) (< status 300)) + (== status 304)) + (unless (== callback null) + (callback response-x-m-l)) + (alert (+ "Error while fetching URI " uri))) + (return))) + (funcall send null)) + (delete request) + (return)))) + +(defgeneric ps-ajax-call (processor)) +(defmethod ps-ajax-call ((processor ajax-processor)) + `(defun ajax-call (func callback args) + (let ((uri (+ ,(server-uri processor) "/" + (encode-u-r-i-component func) "/"))) + (when (> (length args) 0) + (incf uri "?") + (dotimes (i (length args)) + (when (> i 0) + (incf uri "&")) + (incf uri (+ "arg" i "=" (encode-u-r-i-component (aref args i)))))) + (fetch-uri uri callback)))) + + +(defgeneric generate-prologue-javascript (processor)) +(defmethod generate-prologue-javascript ((processor ajax-processor)) + (let* ((namespace (ajax-namespace processor)) + (ajax-fns-in-ns (and namespace (ajax-functions-namespace-p processor))) + (ajax-fns nil) + (ajax-globals nil)) + (maphash-values (lambda (fn) + (with-slots (name) fn + (push (ajax-ps-function processor name) ajax-fns) + (when ajax-fns-in-ns + (let ((ajax-name (ajax-function-name processor name))) + (push `(setf (@ ,namespace ,ajax-name) ,ajax-name) + ajax-globals))))) + (ajax-functions processor)) + (ps* + (if namespace + `(progn + (var ,namespace (create)) + (funcall + (lambda () + ,(ps-fetch-uri processor) + ,(ps-ajax-call processor) + ,(if ajax-fns-in-ns + `(progn ,@ajax-fns ,@ajax-globals) + `(setf (@ ,namespace ajax-call) ajax-call)) + (return))) + ,(unless ajax-fns-in-ns + `(progn ,@ajax-fns))) + (list* 'progn + (ps-fetch-uri processor) + (ps-ajax-call processor) + ajax-fns))))) + + + +;; in the future possibly generate with a html generator. +;; right now exists to hide ugly html. +(defun html-script-cdata (js &key (newlines t)) + "html script/cdata wrapper for javascript + wraps javascript in a html element" + (let ((newline (if newlines (string #\newline) ""))) + (concatenate 'string + ""))) + + + + +(defgeneric generate-prologue (processor)) +(defmethod generate-prologue ((processor ajax-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" + (html-script-cdata (generate-prologue-javascript processor))) + + + +(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 (name (gethash fn-name (ajax-functions 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 + "" + (string #\newline) + "" + (apply fn args) + ""))) \ No newline at end of file