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

Contents of /ht-ajax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Fri Nov 14 21:17:43 2008 UTC (5 years, 5 months ago) by xlopez
File size: 14702 byte(s)
Initial commit, version 0.0.7.
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 (setf (content-type) (or content-type
165 (when (getf funcallable-plist :json) (json-content-type))
166 (default-content-type processor))))
167 (when (default-reply-external-format processor)
168 (setf (reply-external-format) (default-reply-external-format processor)))
169 (unless (getf funcallable-plist :allow-cache)
170 (no-cache))
171
172 (apply funcallable args))))
173
174
175 (defun handle-virtual-file (processor)
176 (let* ((file-name (string-downcase (script-name)))
177 (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 (setf (content-type) "text/javascript")
183 (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 (defun maybe-rewrite-url-for-session (url &key (cookie-name *session-cookie-name*)
285 (value (hunchentoot::session-cookie-value)))
286 "Modelled after (well, copied from) HUNCHENTOOT::MAYBE-REWRITE-URLS-FOR-SESSION.
287 Rewrites the URL such that the name/value pair
288 COOKIE-NAME/COOKIE-VALUE is inserted if the client hasn't sent a
289 cookie of the same name but only if *REWRITE-FOR-SESSION-URLS* is
290 true."
291 (cond
292 ((or (not *rewrite-for-session-urls*)
293 (null value)
294 (cookie-in cookie-name))
295 url)
296 (t
297 (hunchentoot::add-cookie-value-to-url url
298 :cookie-name cookie-name
299 :value value))))
300
301
302 ;;
303
304 (defclass library-ajax-processor (ajax-processor)
305 ((js-file-uris :initarg :js-file-uris :accessor js-file-uris))
306 (:documentation "The class representing a processor that uses an
307 external Javascript library"))
308
309 (defgeneric default-library-file-names (library-ajax-processor)
310 (:documentation "Returns the default filename for Javascript library to
311 be included in the HTML"))
312
313
314 (defmethod initialize-instance :after ((processor library-ajax-processor) &key)
315 (unless (and (slot-boundp processor 'js-file-uris)
316 (js-file-uris processor))
317 (error "Initializing ~A without JS-FILE-URIS" (class-name (class-of processor))))
318 (let ((file-uri (js-file-uris processor)))
319 (when (and (stringp file-uri)
320 (eql (char file-uri (1- (length file-uri))) #\/)) ; Just a path
321 ;; Store default filenames for this processor
322 (setf (js-file-uris processor)
323 (mapcar #'(lambda (fname) (concatenate 'string
324 file-uri fname))
325 (default-library-file-names processor))))
326 ;; If it's a string then wrap it in a list
327 (when (stringp (js-file-uris processor))
328 (setf (js-file-uris processor) (list (js-file-uris processor))))))
329
330
331 (defmethod %generate-includes ((processor library-ajax-processor))
332 (apply #'concatenate 'string
333 (mapcar #'prepare-js-file-include (js-file-uris processor))))
334
335
336 (defmethod prepare-js-ajax-function ((processor library-ajax-processor) fun-name js-fun-name
337 &rest rest &key method &allow-other-keys)
338 (declare (ignore processor))
339 (let ((request-func (ecase method
340 (:get "ajax_call_uri")
341 (:post "ajax_post_uri"))))
342 (apply #'prepare-js-ajax-function-definitions request-func fun-name js-fun-name rest)))

  ViewVC Help
Powered by ViewVC 1.1.5