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