easy-handlers.lisp

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