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."))