easy-handlers.lisp 1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
2
3 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
4
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
8
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
11
12 ;;; * Redistributions in binary form must reproduce the above
13 ;;; copyright notice, this list of conditions and the following
14 ;;; disclaimer in the documentation and/or other materials
15 ;;; provided with the distribution.
16
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28
29 (in-package :hunchentoot)
30
31 (defvar *dispatch-table* (list 'dispatch-easy-handlers)
32 "A global list of dispatch functions.")
33
34 (defvar *easy-handler-alist* nil
35 "An alist of \(URI acceptor-names function) lists defined by
36 DEFINE-EASY-HANDLER.")
37
38 (defun compute-real-name (symbol)
39 "Computes the `real' paramater name \(a string) from the Lisp
40 symbol SYMBOL. Used in cases where no parameter name is
41 provided."
42 ;; we just downcase the symbol's name
43 (string-downcase symbol))
44
45 (defun convert-parameter (argument type)
46 "Converts the string ARGUMENT to TYPE where TYPE is one of the
47 symbols STRING, CHARACTERS, INTEGER, KEYWORD, or BOOLEAN - or
48 otherwise a function designator for a function of one argument.
49 ARGUMENT can also be NIL in which case this function also returns
50 NIL unconditionally."
51 (when (listp argument)
52 ;; this if for the case that ARGUMENT is NIL or the result of a
53 ;; file upload
54 (return-from convert-parameter argument))
55 (case type
56 (string argument)
57 (character (and (= (length argument) 1)
58 (char argument 0)))
59 (integer (ignore-errors* (parse-integer argument :junk-allowed t)))
60 (keyword (as-keyword argument :destructivep nil))
61 (boolean t)
62 (otherwise (funcall type argument))))
63
64 (defun compute-simple-parameter (parameter-name type parameter-reader)
65 "Retrieves the parameter named PARAMETER-NAME using the reader
66 PARAMETER-READER and converts it to TYPE."
67 (convert-parameter (funcall parameter-reader parameter-name) type))
68
69 (defun compute-list-parameter (parameter-name type parameters)
70 "Retrieves all parameters from PARAMETERS which are named
71 PARAMETER-NAME, converts them to TYPE, and returns a list of
72 them."
73 (loop for (name . value) in parameters
74 when (string= name parameter-name)
75 collect (convert-parameter value type)))
76
77 (defun compute-array-parameter (parameter-name type parameters)
78 "Retrieves all parameters from PARAMETERS which are named like
79 \"PARAMETER-NAME[N]\" \(where N is a non-negative integer),
80 converts them to TYPE, and returns an array where the Nth element
81 is the corresponding value."
82 ;; see <http://common-lisp.net/pipermail/tbnl-devel/2006-September/000660.html>
83 #+:sbcl (declare (sb-ext:muffle-conditions warning))
84 (let* ((index-value-list
85 (loop for (full-name . value) in parameters
86 for index = (register-groups-bind (name index-string)
87 ("^(.*)\\[(\\d+)\\]$" full-name)
88 (when (string= name parameter-name)
89 (parse-integer index-string)))
90 when index
91 collect (cons index (convert-parameter value type))))
92 (array (make-array (1+ (reduce #'max index-value-list
93 :key #'car
94 :initial-value -1))
95 :initial-element nil)))
96 (loop for (index . value) in index-value-list
97 do (setf (aref array index) value))
98 array))
99
100 (defun compute-hash-table-parameter (parameter-name type parameters key-type test-function)
101 "Retrieves all parameters from PARAMETERS which are named like
102 \"PARAMETER-NAME{FOO}\" \(where FOO is any sequence of characters
103 not containing curly brackets), converts them to TYPE, and
104 returns a hash table with test function TEST-FUNCTION where the
105 corresponding value is associated with the key FOO \(converted to
106 KEY-TYPE)."
107 (let ((hash-table (make-hash-table :test test-function)))
108 (loop for (full-name . value) in parameters
109 for key = (register-groups-bind (name key-string)
110 ("^(.*){([^{}]+)}$" full-name)
111 (when (string= name parameter-name)
112 (convert-parameter key-string key-type)))
113 when key
114 do (setf (gethash key hash-table)
115 (convert-parameter value type)))
116 hash-table))
117
118 (defun compute-parameter (parameter-name parameter-type request-type)
119 "Computes and returns the parameter\(s) called PARAMETER-NAME
120 and converts it/them according to the value of PARAMETER-TYPE.
121 REQUEST-TYPE is one of :GET, :POST, or :BOTH."
122 (when (member parameter-type '(list array hash-table))
123 (setq parameter-type (list parameter-type 'string)))
124 (let ((parameter-reader (ecase request-type
125 (:get #'get-parameter)
126 (:post #'post-parameter)
127 (:both #'parameter)))
128 (parameters (and (listp parameter-type)
129 (case request-type
130 (:get (get-parameters*))
131 (:post (post-parameters*))
132 (:both (append (get-parameters*) (post-parameters*)))))))
133 (cond ((atom parameter-type)
134 (compute-simple-parameter parameter-name parameter-type parameter-reader))
135 ((and (null (cddr parameter-type))
136 (eq (first parameter-type) 'list))
137 (compute-list-parameter parameter-name (second parameter-type) parameters))
138 ((and (null (cddr parameter-type))
139 (eq (first parameter-type) 'array))
140 (compute-array-parameter parameter-name (second parameter-type) parameters))
141 ((and (null (cddddr parameter-type))
142 (eq (first parameter-type) 'hash-table))
143 (compute-hash-table-parameter parameter-name (second parameter-type) parameters
144 (or (third parameter-type) 'string)
145 (or (fourth parameter-type) 'equal)))
146 (t (parameter-error "Don't know what to do with parameter type ~S." parameter-type)))))
147
148 (defun make-defun-parameter (description default-parameter-type default-request-type)
149 "Creates a keyword parameter to be used by DEFINE-EASY-HANDLER.
150 DESCRIPTION is one of the elements of DEFINE-EASY-HANDLER's
151 LAMBDA-LIST and DEFAULT-PARAMETER-TYPE and DEFAULT-REQUEST-TYPE
152 are the global default values."
153 (when (atom description)
154 (setq description (list description)))
155 (destructuring-bind (parameter-name &key (real-name (compute-real-name parameter-name))
156 parameter-type init-form request-type)
157 description
158 `(,parameter-name (or (and (boundp '*request*)
159 (compute-parameter ,real-name
160 ,(or parameter-type default-parameter-type)
161 ,(or request-type default-request-type)))
162 ,init-form))))
163
164 (defmacro define-easy-handler (description lambda-list &body body)
165 "Defines a handler with the body BODY and optionally registers
166 it with a URI so that it will be found by DISPATCH-EASY-HANDLERS.
167 DESCRIPTION is either a symbol NAME or a list matching the
168 destructuring lambda list
169
170 (name &key uri acceptor-names default-parameter-type default-request-type).
171
172 LAMBDA-LIST is a list the elements of which are either a symbol
173 VAR or a list matching the destructuring lambda list
174
175 (var &key real-name parameter-type init-form request-type).
176
177 The resulting handler will be a Lisp function with the name NAME
178 and keyword parameters named by the VAR symbols. Each VAR will
179 be bound to the value of the GET or POST parameter called
180 REAL-NAME \(a string) before BODY is executed. If REAL-NAME is
181 not provided, it will be computed by downcasing the symbol name
182 of VAR.
183
184 If URI \(which is evaluated) is provided, then it must be a string or
185 a function designator for a function of one argument. In this case,
186 the handler will be returned by DISPATCH-EASY-HANDLERS, if URI is a
187 string and the script name of a request is URI, or if URI designates a
188 function and applying this function to the current request object
189 returns a true value.
190
191 ACCEPTOR-NAMES \(which is evaluated) can be a list of symbols which
192 means that the handler will be returned by DISPATCH-EASY-HANDLERS in
193 acceptors which have one of these names \(see ACCEPTOR-NAME).
194 ACCEPTOR-NAMES can also be the symbol T which means that the handler
195 will be returned by DISPATCH-EASY-HANDLERS in every acceptor.
196
197 Whether the GET or POST parameter \(or both) will be taken into
198 consideration, depends on REQUEST-TYPE which can
199 be :GET, :POST, :BOTH, or NIL. In the last case, the value of
200 DEFAULT-REQUEST-TYPE \(the default of which is :BOTH) will be
201 used.
202
203 The value of VAR will usually be a string \(unless it resulted from a
204 file upload in which case it won't be converted at all), but if
205 PARAMETER-TYPE \(which is evaluated) is provided, the string will be
206 converted to another Lisp type by the following rules:
207
208 If the corresponding GET or POST parameter wasn't provided by the
209 client, VAR's value will be NIL. If PARAMETER-TYPE is 'STRING, VAR's
210 value remains as is. If PARAMETER-TYPE is 'INTEGER and the parameter
211 string consists solely of decimal digits, VAR's value will be the
212 corresponding integer, otherwise NIL. If PARAMETER-TYPE is 'KEYWORD,
213 VAR's value will be the keyword obtained by interning the upcased
214 parameter string into the keyword package. If PARAMETER-TYPE is
215 'CHARACTER and the parameter string is of length one, VAR's value will
216 be the single character of this string, otherwise NIL. If
217 PARAMETER-TYPE is 'BOOLEAN, VAR's value will always be T \(unless it
218 is NIL by the first rule above, of course). If PARAMETER-TYPE is any
219 other atom, it is supposed to be a function designator for a unary
220 function which will be called to convert the string to something else.
221
222 Those were the rules for `simple' types, but PARAMETER-TYPE can
223 also be a list starting with one of the symbols LIST, ARRAY, or
224 HASH-TABLE. The second value of the list must always be a simple
225 parameter type as in the last paragraph - we'll call it the
226 `inner type' below.
227
228 In the case of 'LIST, all GET/POST parameters called REAL-NAME
229 will be collected, converted to the inner type, and assembled
230 into a list which will be the value of VAR.
231
232 In the case of 'ARRAY, all GET/POST parameters which have a name
233 like the result of
234
235 (format nil \"~A[~A]\" real-name n)
236
237 where N is a non-negative integer, will be assembled into an
238 array where the Nth element will be set accordingly, after
239 conversion to the inner type. The array, which will become the
240 value of VAR, will be big enough to hold all matching parameters,
241 but not bigger. Array elements not set as described above will
242 be NIL. Note that VAR will always be bound to an array, which
243 may be empty, so it will never be NIL, even if no appropriate
244 GET/POST parameters are found.
245
246 The full form of a 'HASH-TABLE parameter type is
247
248 (hash-table inner-type key-type test-function),
249
250 but KEY-TYPE and TEST-FUNCTION can be left out in which case they
251 default to 'STRING and 'EQUAL, respectively. For this parameter
252 type, all GET/POST parameters which have a name like the result
253 of
254
255 (format nil \"~A{~A}\" real-name key)
256
257 \(where KEY is a string that doesn't contain curly brackets) will
258 become the values \(after conversion to INNER-TYPE) of a hash
259 table with test function TEST-FUNCTION where KEY \(after
260 conversion to KEY-TYPE) will be the corresponding key. Note that
261 VAR will always be bound to a hash table, which may be empty, so
262 it will never be NIL, even if no appropriate GET/POST parameters
263 are found.
264
265 To make matters even more complicated, the three compound
266 parameter types also have an abbreviated form - just one of the
267 symbols LIST, ARRAY, or HASH-TABLE. In this case, the inner type
268 will default to 'STRING.
269
270 If PARAMETER-TYPE is not provided or NIL, DEFAULT-PARAMETER-TYPE
271 \(the default of which is 'STRING) will be used instead.
272
273 If the result of the computations above would be that VAR would
274 be bound to NIL, then INIT-FORM \(if provided) will be evaluated
275 instead, and VAR will be bound to the result of this evaluation.
276
277 Handlers built with this macro are constructed in such a way that
278 the resulting Lisp function is useful even outside of
279 Hunchentoot. Specifically, all the parameter computations above
280 will only happen if *REQUEST* is bound, i.e. if we're within a
281 Hunchentoot request. Otherwise, VAR will always be bound to the
282 result of evaluating INIT-FORM unless a corresponding keyword
283 argument is provided."
284 (when (atom description)
285 (setq description (list description)))
286 (destructuring-bind (name &key uri (acceptor-names t)
287 (default-parameter-type ''string)
288 (default-request-type :both))
289 description
290 `(progn
291 ,@(when uri
292 (list
293 (with-rebinding (uri)
294 `(progn
295 (setq *easy-handler-alist*
296 (delete-if (lambda (list)
297 (and (or (equal ,uri (first list))
298 (eq ',name (third list)))
299 (or (eq ,acceptor-names t)
300 (intersection ,acceptor-names
301 (second list)))))
302 *easy-handler-alist*))
303 (push (list ,uri ,acceptor-names ',name) *easy-handler-alist*)))))
304 (defun ,name (&key ,@(loop for part in lambda-list
305 collect (make-defun-parameter part
306 default-parameter-type
307 default-request-type)))
308 ,@body))))
309
310 ;; help the LispWorks IDE to find these definitions
311 #+:lispworks
312 (dspec:define-form-parser define-easy-handler (description)
313 `(,define-easy-handler ,(if (atom description) description (first description))))
314
315 #+:lispworks
316 (dspec:define-dspec-alias define-easy-handler (name)
317 `(defun ,name))
318
319 (defun dispatch-easy-handlers (request)
320 "This is a dispatcher which returns the appropriate handler
321 defined with DEFINE-EASY-HANDLER, if there is one."
322 (loop for (uri acceptor-names easy-handler) in *easy-handler-alist*
323 when (and (or (eq acceptor-names t)
324 (find (acceptor-name *acceptor*) acceptor-names :test #'eq))
325 (cond ((stringp uri)
326 (string= (script-name request) uri))
327 (t (funcall uri request))))
328 do (return easy-handler)))
329
330 (defclass easy-acceptor (acceptor)
331 ()
332 (:documentation "This is the acceptor of the ``easy'' Hunchentoot framework."))
333
334 (defmethod acceptor-dispatch-request ((acceptor easy-acceptor) request)
335 "The easy request dispatcher which selects a request handler
336 based on a list of individual request dispatchers all of which can
337 either return a handler or neglect by returning NIL."
338 (loop for dispatcher in *dispatch-table*
339 for action = (funcall dispatcher request)
340 when action return (funcall action)
341 finally (call-next-method)))
342
343 #-:hunchentoot-no-ssl
344 (defclass easy-ssl-acceptor (easy-acceptor ssl-acceptor)
345 ()
346 (:documentation "This is an acceptor that mixes the ``easy''
347 Hunchentoot with SSL connections."))