/[ht-ajax]/ht-ajax.lisp
ViewVC logotype

Contents of /ht-ajax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (hide annotations)
Thu Sep 3 06:11:21 2009 UTC (4 years, 7 months ago) by xlopez
File size: 14821 byte(s)
Port to Hunchentoot 1.0 APIs

Patch by Andrew Stine.
1 xlopez 1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*-
2     ;;;
3     ;;; Copyright (c) 2007, Ury Marshak
4     ;;; The code comes with a BSD-style license, so you can basically do
5     ;;; with it whatever you want. See the file LICENSE for details.
6     ;;;
7    
8     (in-package #:ht-ajax)
9    
10     (declaim #.*optimization*)
11    
12     ;;
13    
14     (defclass ajax-processor ()
15     ((exported-funcs :initform nil :accessor exported-funcs)
16     (server-uri :initarg :server-uri :accessor server-uri)
17     (hunchentoot-handler :accessor hunchentoot-handler)
18     (cached-prologue :accessor cached-prologue :initform nil)
19     (js-debug :accessor js-debug :initarg :js-debug :initform nil)
20     (js-compression :accessor js-compression :initarg :js-compression :initform nil)
21     (ajax-function-prefix :initarg :ajax-function-prefix
22     :accessor ajax-function-prefix :initform "ajax_")
23     (default-content-type :initarg :default-content-type
24     :accessor default-content-type :initform "text/plain; charset=\"utf-8\"")
25     (default-reply-external-format :initarg :default-reply-external-format
26     :accessor default-reply-external-format :initform hunchentoot::+utf-8+)
27     (virtual-js-file :initarg :virtual-js-file
28     :accessor virtual-js-file :initform nil)
29     (virtual-files :accessor virtual-files :initform nil))
30    
31     (:documentation "The class containing all ajax-related handling"))
32    
33    
34     (defmethod initialize-instance :after ((processor ajax-processor) &key)
35     (setf (exported-funcs processor) (make-hash-table :test 'equal))
36     (unless (and (slot-boundp processor 'server-uri)
37     (server-uri processor))
38     (error "Initializing AJAX-PROCESSOR without SERVER-URI.")))
39    
40    
41     ;;
42    
43    
44     (defgeneric handle-request (processor)
45     (:documentation "Process the incoming request from hunchentoot"))
46    
47    
48     (defgeneric export-func (processor funcallable
49     &key method name content-type allow-cache)
50     (:documentation "Makes the function designated by FUNCALLABLE exported (available to call from js)
51     Parameters:
52     METHOD - :get (default) or :post (:post is not supported under SIMPLE processor)
53     NAME - export the function under a different name
54     CONTENT-TYPE - Value of Content-Type header so set on the reply (default: text/plain)
55     ALLOW-CACHE - (default nil) if true then HT-AJAX will not call NO-CACHE function and
56     allow to control cache manually
57     JSON - (default nil) if true, the function returns a JSON-encoded object that will
58     be decoded on the client and passed to the callback
59     "))
60    
61     (defgeneric unexport-func (processor symbol-or-name)
62     (:documentation "Removes the previously exported function, should be called
63     with either the name (string) under which it was exported or the symbol
64     designating the function"))
65    
66    
67     (defmacro defun-ajax (name params (processor &rest export-args) &body body)
68     "Macro, defining a function exported to AJAX
69     Example: (defun-ajax func1 (arg1 arg2) (*ajax-processor*)
70     (do-stuff))"
71     (let ((f (gensym)))
72     `(let ((,f (defun ,name ,params ,@body)))
73     (if ,f (export-func ,processor ',name ,@export-args)))))
74    
75    
76     (defgeneric generate-prologue (processor &key use-cache)
77     (:documentation "Generates the necessary HTML+JS to be included in the web page.
78     Provides caching if USE-CACHE is true (default)"))
79    
80    
81     (defgeneric %generate-includes (processor)
82     (:documentation "Internal generic function to be implemented in specific
83     ajax processor"))
84    
85     (defgeneric %generate-js-code (processor)
86     (:documentation "Internal generic function to be implemented in specific
87     ajax processor"))
88    
89    
90     (defgeneric get-handler (processor)
91     (:documentation "Get the hunchentoot handler for AJAX url.
92     The url that was passed as the SERVER-URI parameter should be
93     dispatched to this handler."))
94    
95    
96     (defgeneric reset-prologue-cache (processor)
97     (:documentation ""))
98    
99    
100     (defgeneric js-function-name (processor function-name)
101     (:documentation ""))
102    
103     (defgeneric prepare-js-ajax-function (processor fun-name js-fun-name
104     &rest rest &key method &allow-other-keys)
105     (:documentation ""))
106    
107     ;;;
108    
109     (defmethod export-func ((processor ajax-processor) funcallable
110     &key (method :get) name content-type allow-cache json)
111     (let ((func-name (or name
112     (when (symbolp funcallable)
113     (symbol-name funcallable)))))
114     (unless func-name
115     (error "Name not provided for ~A" funcallable))
116    
117     (setf (gethash (string-upcase func-name) (exported-funcs processor))
118     `(:funcallable ,funcallable
119     :method ,method
120     :content-type ,content-type
121     :allow-cache ,allow-cache
122     :json ,json))
123     (reset-prologue-cache processor)
124     (values)))
125    
126    
127     (defmethod unexport-func ((processor ajax-processor) symbol-or-name)
128     (let ((func-name (or (when (symbolp symbol-or-name)
129     (symbol-name symbol-or-name))
130     symbol-or-name)))
131     (unless (and func-name
132     (stringp func-name))
133     (error "Invalid name ~S in UNEXPORT-FUNC" symbol-or-name))
134    
135     (remhash (string-upcase func-name) (exported-funcs processor))
136     (reset-prologue-cache processor)
137     (values)))
138    
139    
140    
141     (defmethod handle-request ((processor ajax-processor))
142     ;; See if it's a request for a virtual .JS file
143     (let ((virtual-file-result (handle-virtual-file processor)))
144     (when virtual-file-result
145     (return-from handle-request virtual-file-result)))
146    
147     ;; Not a vitual file, process as a function call
148     (let ((func-name (parameter "ajax-fun"))
149     (num-args (parameter "ajax-num-args")))
150     (unless (and func-name num-args)
151     (error "Error in HANDLE-REQUEST: required parameters missing"))
152    
153     (let* ((args (loop for i from 0 below (parse-integer num-args)
154     for arg-name = (concatenate 'string "ajax-arg" (princ-to-string i))
155     for arg = (parameter arg-name)
156     collect arg))
157     (funcallable-plist (gethash func-name (exported-funcs processor)))
158     (funcallable (getf funcallable-plist :funcallable)))
159     (unless funcallable
160     (error "Error in HANDLE-REQUEST: no such function: ~A" func-name))
161    
162     (let ((content-type (getf funcallable-plist :content-type)))
163     ;; Can't use the default parameter of getf since it may be present but null
164 xlopez 2 (setf (content-type*) (or content-type
165 xlopez 1 (when (getf funcallable-plist :json) (json-content-type))
166     (default-content-type processor))))
167     (when (default-reply-external-format processor)
168 xlopez 2 (setf (reply-external-format*) (default-reply-external-format processor)))
169 xlopez 1 (unless (getf funcallable-plist :allow-cache)
170     (no-cache))
171    
172     (apply funcallable args))))
173    
174    
175     (defun handle-virtual-file (processor)
176 xlopez 2 (let* ((file-name (string-downcase (script-name*)))
177 xlopez 1 (file-record (assoc file-name (virtual-files processor) :test 'equal)))
178     (when file-record
179     (let ((time (cddr file-record)))
180     (handle-if-modified-since time) ; Does not return if the file was not modified
181    
182 xlopez 2 (setf (content-type*) "text/javascript")
183 xlopez 1 (setf (header-out "Last-Modified") (rfc-1123-date time))
184     ;;(setf (header-out "Expires") (rfc-1123-date (+ time #.(* 60 60 2))))
185     (cadr file-record)))))
186    
187    
188     (defun store-virtual-js-file (processor file-contents)
189     "Makes a new unique name for a file, makes an alist of file name and a cons of
190     contents and time, stores the alist in the processor's slot and returns the
191     file name"
192     (let ((file-name (string-downcase (concatenate 'string
193     (server-uri processor)
194     "/"
195     (symbol-name (gensym))
196     ".js"))))
197     (setf (virtual-files processor) (list (cons file-name
198     (cons file-contents (get-universal-time)))))
199     file-name))
200    
201    
202     (defmethod get-handler ((processor ajax-processor))
203     (if (slot-boundp processor 'hunchentoot-handler)
204     (hunchentoot-handler processor)
205     (setf (hunchentoot-handler processor) #'(lambda ()
206     (handle-request processor)))))
207    
208    
209     (defun make-ajax-processor (&rest rest &key (type :simple) &allow-other-keys)
210     "Creates an ajax-processor object. Parameters:
211     TYPE - selects the kind of ajax-processor to use (should be
212     one of:SIMPLE or :LOKRIS, :PROTOTYPE, :YUI or :DOJO) (required)
213     SERVER-URI - url that the ajax function calls will use (required)
214     JS-FILE-URIS - a list of URLs on your server of the .js files that the
215     used library requires , such as lokris.js or prototype.js
216     (parameter required for all processors except :SIMPLE). If
217     only one file needs to be included then instead of a list a single
218     string may be passed. Also if this parameter is a string that ends
219     in a forward slash ( #\/ ) then it is assumed to be a directory
220     and the default file names for the processor are appended to it.
221     AJAX-FUNCTION-PREFIX - the string to be prepended to the generated js functions,
222     (default prefix is \"ajax_\")
223     JS-DEBUG - enable the Javascript debugging function debug_alert(). Overrides
224     such parameters as JS-COMPRESSION and VIRTUAL-FILES
225     JS-COMPRESSION - enable Javascript compression to minimize the download size
226     VIRTUAL-JS-FILE - enable creation of virtual Javascript file instead of
227     inline Javascript code that may be cached on the client to
228     minimize traffic
229     "
230     (let ((params (copy-seq rest)))
231     (remf params :type)
232    
233     ;; make a class name depending on TYPE and create an instance
234     (let* ((class-name (concatenate 'string (symbol-name type) "-ajax-processor"))
235     (class-sym (intern (string-upcase class-name) #.*package*)))
236     (apply #'make-instance class-sym params))))
237    
238    
239     (defmethod generate-prologue ((processor ajax-processor) &key (use-cache t))
240     (let ((cached-prologue (cached-prologue processor)))
241     (if (and cached-prologue use-cache)
242     cached-prologue
243     (let ((prologue (%generate-includes processor))
244     (js-code (%generate-js-code processor)))
245    
246     (when (and (js-compression processor) (js-debug processor))
247     (setf (js-compression processor) nil)
248     (warn "JS-COMPRESSION conflicts with JS-DEBUG, JS-COMPRESSION disabled."))
249    
250     (when (js-compression processor)
251     (setf js-code (jsmin js-code)))
252    
253     (when (and (virtual-js-file processor) (js-debug processor))
254     (setf (virtual-js-file processor) nil)
255     (warn "VIRTUAL-JS-FILE conflicts with JS-DEBUG, VIRTUAL-JS-FILE disabled."))
256    
257     (if (virtual-js-file processor)
258     ;; Create a virtual file and use a link to it
259     (let ((file-name (store-virtual-js-file processor js-code)))
260     (setf prologue (concatenate 'string
261     "<!-- HT-AJAX " +version+ "-->"
262     prologue
263     (prepare-js-file-include file-name))))
264     ;; Not using virtual file, create inline <script> tag
265     (setf prologue (concatenate 'string
266     "<!-- HT-AJAX " +version+ "-->"
267     prologue
268     (wrap-js-in-script-tags js-code))))
269    
270     (setf (cached-prologue processor) prologue)))))
271    
272    
273    
274     (defmethod reset-prologue-cache ((processor ajax-processor))
275     (setf (cached-prologue processor) nil))
276    
277    
278     (defmethod js-function-name ((processor ajax-processor) function-name)
279     (concatenate 'string
280     (ajax-function-prefix processor)
281     (string-downcase (make-safe-js-name function-name))))
282    
283    
284 xlopez 2 (defun maybe-rewrite-url-for-session (url &key (cookie-name (hunchentoot:session-cookie-name hunchentoot:*acceptor*))
285     (value (let ((session (session *request*)))
286     (when session
287     (hunchentoot::session-cookie-value session)))))
288 xlopez 1 "Modelled after (well, copied from) HUNCHENTOOT::MAYBE-REWRITE-URLS-FOR-SESSION.
289     Rewrites the URL such that the name/value pair
290     COOKIE-NAME/COOKIE-VALUE is inserted if the client hasn't sent a
291     cookie of the same name but only if *REWRITE-FOR-SESSION-URLS* is
292     true."
293     (cond
294     ((or (not *rewrite-for-session-urls*)
295     (null value)
296     (cookie-in cookie-name))
297     url)
298     (t
299     (hunchentoot::add-cookie-value-to-url url
300     :cookie-name cookie-name
301     :value value))))
302    
303    
304     ;;
305    
306     (defclass library-ajax-processor (ajax-processor)
307     ((js-file-uris :initarg :js-file-uris :accessor js-file-uris))
308     (:documentation "The class representing a processor that uses an
309     external Javascript library"))
310    
311     (defgeneric default-library-file-names (library-ajax-processor)
312     (:documentation "Returns the default filename for Javascript library to
313     be included in the HTML"))
314    
315    
316     (defmethod initialize-instance :after ((processor library-ajax-processor) &key)
317     (unless (and (slot-boundp processor 'js-file-uris)
318     (js-file-uris processor))
319     (error "Initializing ~A without JS-FILE-URIS" (class-name (class-of processor))))
320     (let ((file-uri (js-file-uris processor)))
321     (when (and (stringp file-uri)
322     (eql (char file-uri (1- (length file-uri))) #\/)) ; Just a path
323     ;; Store default filenames for this processor
324     (setf (js-file-uris processor)
325     (mapcar #'(lambda (fname) (concatenate 'string
326     file-uri fname))
327     (default-library-file-names processor))))
328     ;; If it's a string then wrap it in a list
329     (when (stringp (js-file-uris processor))
330     (setf (js-file-uris processor) (list (js-file-uris processor))))))
331    
332    
333     (defmethod %generate-includes ((processor library-ajax-processor))
334     (apply #'concatenate 'string
335     (mapcar #'prepare-js-file-include (js-file-uris processor))))
336    
337    
338     (defmethod prepare-js-ajax-function ((processor library-ajax-processor) fun-name js-fun-name
339     &rest rest &key method &allow-other-keys)
340     (declare (ignore processor))
341     (let ((request-func (ecase method
342     (:get "ajax_call_uri")
343     (:post "ajax_post_uri"))))
344     (apply #'prepare-js-ajax-function-definitions request-func fun-name js-fun-name rest)))

  ViewVC Help
Powered by ViewVC 1.1.5