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