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 host) 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 host
 171         default-parameter-type default-request-type).
 172
 173 LAMBDA-LIST is a list the elements of which are either a symbol
 174 VAR or a list matching the destructuring lambda list
 175
 176   (var &key real-name parameter-type init-form request-type).
 177
 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.
 184
 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.
 191 HOST, if given, is compared to the given host as well
 192 (don't forget the port number).
 193
 194 ACCEPTOR-NAMES \(which is evaluated) can be a list of symbols which
 195 means that the handler will be returned by DISPATCH-EASY-HANDLERS in
 196 acceptors which have one of these names \(see ACCEPTOR-NAME).
 197 ACCEPTOR-NAMES can also be the symbol T which means that the handler
 198 will be returned by DISPATCH-EASY-HANDLERS in every acceptor.
 199
 200 Whether the GET or POST parameter \(or both) will be taken into
 201 consideration, depends on REQUEST-TYPE which can
 202 be :GET, :POST, :BOTH, or NIL.  In the last case, the value of
 203 DEFAULT-REQUEST-TYPE \(the default of which is :BOTH) will be
 204 used.
 205
 206 The value of VAR will usually be a string \(unless it resulted from a
 207 file upload in which case it won't be converted at all), but if
 208 PARAMETER-TYPE \(which is evaluated) is provided, the string will be
 209 converted to another Lisp type by the following rules:
 210
 211 If the corresponding GET or POST parameter wasn't provided by the
 212 client, VAR's value will be NIL.  If PARAMETER-TYPE is 'STRING, VAR's
 213 value remains as is.  If PARAMETER-TYPE is 'INTEGER and the parameter
 214 string consists solely of decimal digits, VAR's value will be the
 215 corresponding integer, otherwise NIL.  If PARAMETER-TYPE is 'KEYWORD,
 216 VAR's value will be the keyword obtained by interning the upcased
 217 parameter string into the keyword package.  If PARAMETER-TYPE is
 218 'CHARACTER and the parameter string is of length one, VAR's value will
 219 be the single character of this string, otherwise NIL.  If
 220 PARAMETER-TYPE is 'BOOLEAN, VAR's value will always be T \(unless it
 221 is NIL by the first rule above, of course).  If PARAMETER-TYPE is any
 222 other atom, it is supposed to be a function designator for a unary
 223 function which will be called to convert the string to something else.
 224
 225 Those were the rules for `simple' types, but PARAMETER-TYPE can
 226 also be a list starting with one of the symbols LIST, ARRAY, or
 227 HASH-TABLE.  The second value of the list must always be a simple
 228 parameter type as in the last paragraph - we'll call it the
 229 `inner type' below.
 230
 231 In the case of 'LIST, all GET/POST parameters called REAL-NAME
 232 will be collected, converted to the inner type, and assembled
 233 into a list which will be the value of VAR.
 234
 235 In the case of 'ARRAY, all GET/POST parameters which have a name
 236 like the result of
 237
 238   (format nil \"~A[~A]\" real-name n)
 239
 240 where N is a non-negative integer, will be assembled into an
 241 array where the Nth element will be set accordingly, after
 242 conversion to the inner type.  The array, which will become the
 243 value of VAR, will be big enough to hold all matching parameters,
 244 but not bigger.  Array elements not set as described above will
 245 be NIL.  Note that VAR will always be bound to an array, which
 246 may be empty, so it will never be NIL, even if no appropriate
 247 GET/POST parameters are found.
 248
 249 The full form of a 'HASH-TABLE parameter type is
 250
 251   (hash-table inner-type key-type test-function),
 252
 253 but KEY-TYPE and TEST-FUNCTION can be left out in which case they
 254 default to 'STRING and 'EQUAL, respectively.  For this parameter
 255 type, all GET/POST parameters which have a name like the result
 256 of
 257
 258   (format nil \"~A{~A}\" real-name key)
 259
 260 \(where KEY is a string that doesn't contain curly brackets) will
 261 become the values \(after conversion to INNER-TYPE) of a hash
 262 table with test function TEST-FUNCTION where KEY \(after
 263 conversion to KEY-TYPE) will be the corresponding key.  Note that
 264 VAR will always be bound to a hash table, which may be empty, so
 265 it will never be NIL, even if no appropriate GET/POST parameters
 266 are found.
 267
 268 To make matters even more complicated, the three compound
 269 parameter types also have an abbreviated form - just one of the
 270 symbols LIST, ARRAY, or HASH-TABLE.  In this case, the inner type
 271 will default to 'STRING.
 272
 273 If PARAMETER-TYPE is not provided or NIL, DEFAULT-PARAMETER-TYPE
 274 \(the default of which is 'STRING) will be used instead.
 275
 276 If the result of the computations above would be that VAR would
 277 be bound to NIL, then INIT-FORM \(if provided) will be evaluated
 278 instead, and VAR will be bound to the result of this evaluation.
 279
 280 Handlers built with this macro are constructed in such a way that
 281 the resulting Lisp function is useful even outside of
 282 Hunchentoot.  Specifically, all the parameter computations above
 283 will only happen if *REQUEST* is bound, i.e. if we're within a
 284 Hunchentoot request.  Otherwise, VAR will always be bound to the
 285 result of evaluating INIT-FORM unless a corresponding keyword
 286 argument is provided."
 287   (when (atom description)
 288     (setq description (list description)))
 289   (destructuring-bind (name &key uri host (acceptor-names t)
 290                             (default-parameter-type ''string)
 291                             (default-request-type :both))
 292       description
 293     `(progn
 294        ,@(when uri
 295            (list
 296             (once-only (uri host acceptor-names)
 297               `(progn
 298                  (setq *easy-handler-alist*
 299                        (delete-if (lambda (list)
 300                                     (and (or (and (equal ,uri (first list))
 301                                                   ,(if host
 302                                                       `(string= ,host (fourth list))))
 303                                              (eq ',name (third list)))
 304                                          (or (eq ,acceptor-names t)
 305                                              (eq (second list) t)
 306                                              (intersection ,acceptor-names
 307                                                            (second list)))))
 308                                   *easy-handler-alist*))
 309                  (push (list ,uri ,acceptor-names ',name ,host) *easy-handler-alist*)))))
 310        (defun ,name (&key ,@(loop for part in lambda-list
 311                                   collect (make-defun-parameter part
 312                                                                 default-parameter-type
 313                                                                 default-request-type)))
 314          ,@body))))
 315
 316 ;; help the LispWorks IDE to find these definitions
 317 #+:lispworks
 318 (dspec:define-form-parser define-easy-handler (description)
 319   `(,define-easy-handler ,(if (atom description) description (first description))))
 320
 321 #+:lispworks
 322 (dspec:define-dspec-alias define-easy-handler (name)
 323   `(defun ,name))
 324
 325 (defun dispatch-easy-handlers (request)
 326   "This is a dispatcher which returns the appropriate handler
 327 defined with DEFINE-EASY-HANDLER, if there is one."
 328   (loop for (uri acceptor-names easy-handler host) in *easy-handler-alist*
 329         when (and (or (eq acceptor-names t)
 330                       (find (acceptor-name *acceptor*) acceptor-names :test #'eq))
 331                   (cond ((stringp uri)
 332                          (and (or (null host)
 333                                   (string= (or (host request) "unknown")
 334                                            host))
 335                               ;; Support RE for matching host names as well (wildcards)?
 336                               (string= (script-name request) uri)))
 337                         (t (funcall uri request))))
 338         do (return easy-handler)))
 339
 340 (defclass easy-acceptor (acceptor)
 341   ()
 342   (:documentation "This is the acceptor of the ``easy'' Hunchentoot framework."))
 343
 344 (defmethod acceptor-dispatch-request ((acceptor easy-acceptor) request)
 345   "The easy request dispatcher which selects a request handler
 346 based on a list of individual request dispatchers all of which can
 347 either return a handler or neglect by returning NIL."
 348   (loop for dispatcher in *dispatch-table*
 349      for action = (funcall dispatcher request)
 350      when action return (funcall action)
 351      finally (return (call-next-method))))
 352
 353 #-:hunchentoot-no-ssl
 354 (defclass easy-ssl-acceptor (easy-acceptor ssl-acceptor)
 355   ()
 356   (:documentation "This is an acceptor that mixes the ``easy''
 357   Hunchentoot with SSL connections."))