request.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 (defclass request ()
  32   ((acceptor :initarg :acceptor
  33              :documentation "The acceptor which created this request
  34 object."
  35              :reader request-acceptor)
  36    (headers-in :initarg :headers-in
  37                :documentation "An alist of the incoming headers."
  38                :reader headers-in)
  39    (method :initarg :method
  40            :documentation "The request method as a keyword."
  41            :reader request-method)
  42    (uri :initarg :uri
  43         :documentation "The request URI as a string."
  44         :reader request-uri)
  45    (server-protocol :initarg :server-protocol
  46                     :documentation "The HTTP protocol as a keyword."
  47                     :reader server-protocol)
  48    (remote-addr :initarg :remote-addr
  49                 :documentation "The IP address of the client that
  50 initiated this request."
  51                 :reader remote-addr)
  52    (remote-port :initarg :remote-port
  53                 :documentation "The TCP port number of the client
  54 socket from which this request originated."
  55                 :reader remote-port)
  56    (content-stream :initarg :content-stream
  57                    :reader content-stream
  58                    :documentation "A stream from which the request
  59 body can be read if there is one.")
  60    (cookies-in :initform nil
  61                :documentation "An alist of the cookies sent by the client."
  62                :reader cookies-in)
  63    (get-parameters :initform nil
  64                    :documentation "An alist of the GET parameters sent
  65 by the client."
  66                    :reader get-parameters)
  67    (post-parameters :initform nil
  68                     :documentation "An alist of the POST parameters
  69 sent by the client."
  70                     :reader post-parameters)
  71    (script-name :initform nil
  72                 :documentation "The URI requested by the client without
  73 the query string."
  74                 :reader script-name)
  75    (query-string :initform nil
  76                  :documentation "The query string of this request."
  77                  :reader query-string)
  78    (session :initform nil
  79             :accessor session
  80             :documentation "The session object associated with this
  81 request.")
  82    (aux-data :initform nil
  83              :accessor aux-data
  84              :documentation "Used to keep a user-modifiable alist with
  85 arbitrary data during the request.")
  86    (raw-post-data :initform nil
  87                   :documentation "The raw string sent as the body of a
  88 POST request, populated only if not a multipart/form-data request."))
  89   (:documentation "Objects of this class hold all the information
  90 about an incoming request.  They are created automatically by
  91 acceptors and can be accessed by the corresponding handler.
  92
  93 You should not mess with the slots of these objects directly, but you
  94 can subclass REQUEST in order to implement your own behaviour.  See
  95 the REQUEST-CLASS slot of the ACCEPTOR class."))
  96
  97 (defgeneric process-request (request)
  98   (:documentation "This function is called by PROCESS-CONNECTION after
  99 the incoming headers have been read.  It calls HANDLE-REQUEST to
 100 select and call a handler and sends the output of this handler to the
 101 client using START-OUTPUT.  Note that PROCESS-CONNECTION is called
 102 once per connection and loops in case of a persistent connection while
 103 PROCESS-REQUEST is called anew for each request.
 104
 105 Essentially, you can view process-request as a thin wrapper around
 106 HANDLE-REQUEST.
 107
 108 The return value of this function is ignored."))
 109
 110 (defun convert-hack (string external-format)
 111   "The rfc2388 package is buggy in that it operates on a character
 112 stream and thus only accepts encodings which are 8 bit transparent.
 113 In order to support different encodings for parameter values
 114 submitted, we post process whatever string values the rfc2388 package
 115 has returned."
 116   (flex:octets-to-string (map '(vector (unsigned-byte 8) *) 'char-code string)
 117                          :external-format external-format))
 118
 119 (defun parse-rfc2388-form-data (stream content-type-header external-format)
 120   "Creates an alist of POST parameters from the stream STREAM which is
 121 supposed to be of content type 'multipart/form-data'."
 122   (let* ((parsed-content-type-header (rfc2388:parse-header content-type-header :value))
 123          (boundary (or (cdr (rfc2388:find-parameter
 124                              "BOUNDARY"
 125                              (rfc2388:header-parameters parsed-content-type-header)))
 126                        (return-from parse-rfc2388-form-data))))
 127     (loop for part in (rfc2388:parse-mime stream boundary)
 128           for headers = (rfc2388:mime-part-headers part)
 129           for content-disposition-header = (rfc2388:find-content-disposition-header headers)
 130           for name = (cdr (rfc2388:find-parameter
 131                            "NAME"
 132                            (rfc2388:header-parameters content-disposition-header)))
 133           when name
 134           collect (cons name
 135                         (let ((contents (rfc2388:mime-part-contents part)))
 136                           (if (pathnamep contents)
 137                             (list contents
 138                                   (rfc2388:get-file-name headers)
 139                                   (rfc2388:content-type part :as-string t))
 140                             (convert-hack contents external-format)))))))
 141
 142 (defun get-post-data (&key (request *request*) want-stream (already-read 0))
 143   "Reads the request body from the stream and stores the raw contents
 144 \(as an array of octets) in the corresponding slot of the REQUEST
 145 object.  Returns just the stream if WANT-STREAM is true.  If there's a
 146 Content-Length header, it is assumed, that ALREADY-READ octets have
 147 already been read."
 148   (let* ((headers-in (headers-in request))
 149          (content-length (when-let (content-length-header (cdr (assoc :content-length headers-in
 150                                                                       :test #'eq)))
 151                            (parse-integer content-length-header :junk-allowed t)))
 152          (content-stream (content-stream request)))
 153     (setf (slot-value request 'raw-post-data)
 154           (cond (want-stream
 155                  (let ((stream (make-flexi-stream content-stream :external-format +latin-1+)))
 156                    (when content-length
 157                      (setf (flexi-stream-bound stream) content-length))
 158                    stream))
 159                 ((and content-length (> content-length already-read))
 160                  (decf content-length already-read)
 161                  (when (input-chunking-p)
 162                    ;; see RFC 2616, section 4.4
 163                    (log-message* :warning "Got Content-Length header although input chunking is on."))
 164                  (let ((content (make-array content-length :element-type 'octet)))
 165                    (read-sequence content content-stream)
 166                    content))
 167                 ((input-chunking-p)
 168                  (loop with buffer = (make-array +buffer-length+ :element-type 'octet)
 169                        with content = (make-array 0 :element-type 'octet :adjustable t)
 170                        for index = 0 then (+ index pos)
 171                        for pos = (read-sequence buffer content-stream)
 172                        do (adjust-array content (+ index pos))
 173                           (replace content buffer :start1 index :end2 pos)
 174                        while (= pos +buffer-length+)
 175                        finally (return content)))))))
 176
 177 (defmethod initialize-instance :after ((request request) &rest init-args)
 178   "The only initarg for a REQUEST object is :HEADERS-IN.  All other
 179 slot values are computed in this :AFTER method."
 180   (declare (ignore init-args))
 181   (with-slots (headers-in cookies-in get-parameters script-name query-string session)
 182       request
 183     (handler-case*
 184         (progn
 185           (let* ((uri (request-uri request))
 186                  (match-start (position #\? uri)))
 187             (cond
 188              (match-start
 189               (setq script-name (subseq uri 0 match-start)
 190                     query-string (subseq uri (1+ match-start))))
 191              (t (setq script-name uri))))
 192           ;; some clients (e.g. ASDF-INSTALL) send requests like
 193           ;; "GET http://server/foo.html HTTP/1.0"...
 194           (setq script-name (regex-replace "^https?://[^/]+" script-name ""))
 195           ;; compute GET parameters from query string and cookies from
 196           ;; the incoming 'Cookie' header
 197           (setq get-parameters
 198                 (let ((*substitution-char* #\?))
 199                   (form-url-encoded-list-to-alist (split "&" query-string)))
 200                 cookies-in
 201                 (cookies-to-alist (split "\\s*[,;]\\s*" (cdr (assoc :cookie headers-in
 202                                                                     :test #'eq))))
 203                 session (session-verify request)
 204                 *session* session))
 205       (error (condition)
 206         (log-message* :error "Error when creating REQUEST object: ~A" condition)
 207         ;; we assume it's not our fault...
 208         (setf (return-code*) +http-bad-request+)))))
 209
 210 (defmethod process-request (request)
 211   "Standard implementation for processing a request.  You should not
 212 change or replace this functionality unless you know what you're
 213 doing."
 214   (catch 'request-processed ; used by HTTP HEAD handling to end request processing in a HEAD request (see START-OUTPUT)
 215     (let (*tmp-files*
 216           *headers-sent*
 217           (*request* request))
 218       (unwind-protect
 219            (with-mapped-conditions ()
 220              (labels
 221                  ((report-error-to-client (error &optional backtrace)
 222                     (when *log-lisp-errors-p*
 223                       (log-message* *lisp-errors-log-level* "~A~@[~%~A~]" error (when *log-lisp-backtraces-p*
 224                                                                                   backtrace)))
 225                     (start-output +http-internal-server-error+
 226                                   (acceptor-status-message *acceptor*
 227                                                            +http-internal-server-error+
 228                                                            :error (princ-to-string error)
 229                                                            :backtrace (princ-to-string backtrace)))))
 230                (multiple-value-bind (body error backtrace)
 231                    ;; skip dispatch if bad request
 232                    (when (eql (return-code *reply*) +http-ok+)
 233                      (catch 'handler-done
 234                        (handle-request *acceptor* *request*)))
 235                  (when error
 236                    ;; error occured in request handler
 237                    (report-error-to-client error backtrace))
 238                  (unless *headers-sent*
 239                    (handler-case
 240                        (with-debugger
 241                          (start-output (return-code *reply*)
 242                                        (or (acceptor-status-message *acceptor*
 243                                                                     (return-code *reply*))
 244                                            body)))
 245                      (error (e)
 246                        ;; error occured while writing to the client.  attempt to report.
 247                        (report-error-to-client e)))))))
 248         (dolist (path *tmp-files*)
 249           (when (and (pathnamep path) (probe-file path))
 250             ;; the handler may have chosen to (re)move the uploaded
 251             ;; file, so ignore errors that happen during deletion
 252             (ignore-errors*
 253               (delete-file path))))))))
 254
 255 (defun within-request-p ()
 256   "True if we're in the context of a request, otherwise nil."
 257   (and (boundp '*request*) *request*))
 258
 259 (defun parse-multipart-form-data (request external-format)
 260   "Parse the REQUEST body as multipart/form-data, assuming that its
 261 content type has already been verified.  Returns the form data as
 262 alist or NIL if there was no data or the data could not be parsed."
 263   (handler-case*
 264       (let ((content-stream (make-flexi-stream (content-stream request) :external-format +latin-1+)))
 265         (prog1
 266             (parse-rfc2388-form-data content-stream (header-in :content-type request) external-format)
 267           (let ((stray-data (get-post-data :already-read (flexi-stream-position content-stream))))
 268             (when (and stray-data (plusp (length stray-data)))
 269               (hunchentoot-warn "~A octets of stray data after form-data sent by client."
 270                                 (length stray-data))))))
 271     (error (condition)
 272       (log-message* :error "While parsing multipart/form-data parameters: ~A" condition)
 273       nil)))
 274
 275 (defun maybe-read-post-parameters (&key (request *request*) force external-format)
 276   "Make surce that any POST parameters in the REQUEST are parsed.  The
 277 body of the request must be either application/x-www-form-urlencoded
 278 or multipart/form-data to be considered as containing POST parameters.
 279 If FORCE is true, parsing is done unconditionally.  Otherwise, parsing
 280 will only be done if the RAW-POST-DATA slot in the REQUEST is false.
 281 EXTERNAL-FORMAT specifies the external format of the data in the
 282 request body.  By default, the encoding is determined from the
 283 Content-Type header of the request or from
 284 *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* if none is found."
 285   (when (and (header-in :content-type request)
 286              (member (request-method request) *methods-for-post-parameters* :test #'eq)
 287              (or force
 288                  (not (slot-value request 'raw-post-data)))
 289              ;; can't reparse multipart posts, even when FORCEd
 290              (not (eq t (slot-value request 'raw-post-data))))
 291     (unless (or (header-in :content-length request)
 292                 (input-chunking-p))
 293       (log-message* :warning "Can't read request body because there's ~
 294 no Content-Length header and input chunking is off.")
 295       (return-from maybe-read-post-parameters nil))
 296     (handler-case*
 297         (multiple-value-bind (type subtype charset)
 298               (parse-content-type (header-in :content-type request))
 299           (let ((external-format (or external-format
 300                                      (when charset
 301                                        (handler-case
 302                                            (make-external-format charset :eol-style :lf)
 303                                          (error ()
 304                                            (hunchentoot-warn "Ignoring ~
 305 unknown character set ~A in request content type."
 306                                                  charset))))
 307                                      *hunchentoot-default-external-format*)))
 308             (setf (slot-value request 'post-parameters)
 309                   (cond ((and (string-equal type "application")
 310                               (string-equal subtype "x-www-form-urlencoded"))
 311                          (form-url-encoded-list-to-alist
 312                           (split "&" (raw-post-data :request request :external-format +latin-1+))
 313                           external-format))
 314                         ((and (string-equal type "multipart")
 315                               (string-equal subtype "form-data"))
 316                          (prog1 (parse-multipart-form-data request external-format)
 317                            (setf (slot-value request 'raw-post-data) t)))))))
 318       (error (condition)
 319         (log-message* :error "Error when reading POST parameters from body: ~A" condition)
 320         ;; this is not the right thing to do because it could happen
 321         ;; that we aren't finished reading from the request stream and
 322         ;; can't send a reply - to be revisited
 323         (setf (return-code*) +http-bad-request+
 324               *close-hunchentoot-stream* t)
 325         (abort-request-handler)))))
 326
 327 (defun recompute-request-parameters (&key (request *request*)
 328                                           (external-format *hunchentoot-default-external-format*))
 329   "Recomputes the GET and POST parameters for the REQUEST object
 330 REQUEST.  This only makes sense if you're switching external formats
 331 during the request."
 332   (maybe-read-post-parameters :request request :force t :external-format external-format)
 333   (setf (slot-value request 'get-parameters)
 334         (form-url-encoded-list-to-alist (split "&" (query-string request)) external-format))
 335   (values))
 336
 337 (defun script-name* (&optional (request *request*))
 338   "Returns the file name of the REQUEST object REQUEST. That's the
 339 requested URI without the query string \(i.e the GET parameters)."
 340   (script-name request))
 341
 342 (defun query-string* (&optional (request *request*))
 343   "Returns the query string of the REQUEST object REQUEST. That's
 344 the part behind the question mark \(i.e. the GET parameters)."
 345   (query-string request))
 346
 347 (defun get-parameters* (&optional (request *request*))
 348   "Returns an alist of the GET parameters associated with the REQUEST
 349 object REQUEST."
 350   (get-parameters request))
 351
 352 (defmethod post-parameters :before ((request request))
 353   ;; Force here because if someone calls POST-PARAMETERS they actually
 354   ;; want them, regardless of why the RAW-POST-DATA has been filled
 355   ;; in. (For instance, if SEND-HEADERS has been called, filling in
 356   ;; RAW-POST-DATA, and then subsequent code calls POST-PARAMETERS,
 357   ;; without the :FORCE flag POST-PARAMETERS would return NIL.)
 358   (maybe-read-post-parameters
 359    :request request :force (not (slot-value request 'post-parameters))))
 360
 361 (defun post-parameters* (&optional (request *request*))
 362   "Returns an alist of the POST parameters associated with the REQUEST
 363 object REQUEST."
 364   (post-parameters request))
 365
 366 (defun headers-in* (&optional (request *request*))
 367   "Returns an alist of the incoming headers associated with the
 368 REQUEST object REQUEST."
 369   (headers-in request))
 370
 371 (defun cookies-in* (&optional (request *request*))
 372   "Returns an alist of all cookies associated with the REQUEST object
 373 REQUEST."
 374   (cookies-in request))
 375
 376 (defgeneric header-in (name request)
 377   (:documentation "Returns the incoming header with name NAME.  NAME
 378 can be a keyword \(recommended) or a string.")
 379   (:method (name request)
 380    (cdr (assoc* name (headers-in request)))))
 381
 382 (defun header-in* (name &optional (request *request*))
 383   "Returns the incoming header with name NAME.  NAME can be a keyword
 384 \(recommended) or a string."
 385   (header-in name request))
 386
 387 (defun authorization (&optional (request *request*))
 388   "Returns as two values the user and password \(if any) as encoded in
 389 the 'AUTHORIZATION' header.  Returns NIL if there is no such header."
 390   (let* ((authorization (header-in :authorization request))
 391          (start (and authorization
 392                      (> (length authorization) 5)
 393                      (string-equal "Basic" authorization :end2 5)
 394                      (scan "\\S" authorization :start 5))))
 395     (when start
 396       (destructuring-bind (&optional user password)
 397           (split ":" (base64:base64-string-to-string (subseq authorization start)))
 398         (values user password)))))
 399
 400 (defun remote-addr* (&optional (request *request*))
 401   "Returns the address the current request originated from."
 402   (remote-addr request))
 403
 404 (defun remote-port* (&optional (request *request*))
 405   "Returns the port the current request originated from."
 406   (remote-port request))
 407
 408 (defun real-remote-addr (&optional (request *request*))
 409   "Returns the 'X-Forwarded-For' incoming http header as the
 410 second value in the form of a list of IP addresses and the first
 411 element of this list as the first value if this header exists.
 412 Otherwise returns the value of REMOTE-ADDR as the only value."
 413   (let ((x-forwarded-for (header-in :x-forwarded-for request)))
 414     (cond (x-forwarded-for (let ((addresses (split "\\s*,\\s*" x-forwarded-for)))
 415                              (values (first addresses) addresses)))
 416           (t (remote-addr request)))))
 417
 418 (defun host (&optional (request *request*))
 419   "Returns the 'Host' incoming http header value."
 420   (header-in :host request))
 421
 422 (defun request-uri* (&optional (request *request*))
 423   "Returns the request URI."
 424   (request-uri request))
 425
 426 (defun request-method* (&optional (request *request*))
 427   "Returns the request method as a Lisp keyword."
 428   (request-method request))
 429
 430 (defun server-protocol* (&optional (request *request*))
 431   "Returns the request protocol as a Lisp keyword."
 432   (server-protocol request))
 433
 434 (defun user-agent (&optional (request *request*))
 435   "Returns the 'User-Agent' http header."
 436   (header-in :user-agent request))
 437
 438 (defun cookie-in (name &optional (request *request*))
 439   "Returns the cookie with the name NAME \(a string) as sent by the
 440 browser - or NIL if there is none."
 441   (cdr (assoc name (cookies-in request) :test #'string=)))
 442
 443 (defun referer (&optional (request *request*))
 444   "Returns the 'Referer' \(sic!) http header."
 445   (header-in :referer request))
 446
 447 (defun get-parameter (name &optional (request *request*))
 448   "Returns the GET parameter with name NAME \(a string) - or NIL if
 449 there is none.  Search is case-sensitive."
 450   (cdr (assoc name (get-parameters request) :test #'string=)))
 451
 452 (defun post-parameter (name &optional (request *request*))
 453   "Returns the POST parameter with name NAME \(a string) - or NIL if
 454 there is none.  Search is case-sensitive."
 455   (cdr (assoc name (post-parameters request) :test #'string=)))
 456
 457 (defun parameter (name &optional (request *request*))
 458   "Returns the GET or the POST parameter with name NAME \(a string) -
 459 or NIL if there is none.  If both a GET and a POST parameter with the
 460 same name exist the GET parameter is returned.  Search is
 461 case-sensitive."
 462   (or (get-parameter name request)
 463       (post-parameter name request)))
 464
 465 (defun handle-if-modified-since (time &optional (request *request*))
 466   "Handles the 'If-Modified-Since' header of REQUEST.  The date string
 467 is compared to the one generated from the supplied universal time
 468 TIME."
 469   (let ((if-modified-since (header-in :if-modified-since request))
 470         (time-string (rfc-1123-date time)))
 471     ;; simple string comparison is sufficient; see RFC 2616 14.25
 472     (when (and if-modified-since
 473                (equal if-modified-since time-string))
 474       (setf (return-code*) +http-not-modified+)
 475       (abort-request-handler))
 476     (values)))
 477
 478 (defun external-format-from-content-type (content-type)
 479   "Creates and returns an external format corresponding to the value
 480 of the content type header provided in CONTENT-TYPE.  If the content
 481 type was not set or if the character set specified was invalid, NIL is
 482 returned."
 483   (when content-type
 484     (when-let (charset (nth-value 2 (parse-content-type content-type)))
 485       (handler-case
 486           (make-external-format (as-keyword charset) :eol-style :lf)
 487         (error ()
 488           (hunchentoot-warn "Invalid character set ~S in request has been ignored."
 489                             charset))))))
 490
 491 (defun raw-post-data (&key (request *request*) external-format force-text force-binary want-stream)
 492   "Returns the content sent by the client if there was any \(unless
 493 the content type was \"multipart/form-data\").  By default, the result
 494 is a string if the type of the `Content-Type' media type is \"text\",
 495 and a vector of octets otherwise.  In the case of a string, the
 496 external format to be used to decode the content will be determined
 497 from the `charset' parameter sent by the client \(or otherwise
 498 *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* will be used).
 499
 500 You can also provide an external format explicitly \(through
 501 EXTERNAL-FORMAT) in which case the result will unconditionally be a
 502 string.  Likewise, you can provide a true value for FORCE-TEXT which
 503 will force Hunchentoot to act as if the type of the media type had
 504 been \"text\".  Or you can provide a true value for FORCE-BINARY which
 505 means that you want a vector of octets at any rate.
 506
 507 If, however, you provide a true value for WANT-STREAM, the other
 508 parameters are ignored and you'll get the content \(flexi) stream to
 509 read from it yourself.  It is then your responsibility to read the
 510 correct amount of data, because otherwise you won't be able to return
 511 a response to the client.  If the content type of the request was
 512 `multipart/form-data' or `application/x-www-form-urlencoded', the
 513 content has been read by Hunchentoot already and you can't read from
 514 the stream anymore.
 515
 516 You can call RAW-POST-DATA more than once per request, but you can't
 517 mix calls which have different values for WANT-STREAM.
 518
 519 Note that this function is slightly misnamed because a client can send
 520 content even if the request method is not POST."
 521   (when (and force-binary force-text)
 522     (parameter-error "It doesn't make sense to set both FORCE-BINARY and FORCE-TEXT to a true value."))
 523   (unless (or external-format force-binary)
 524     (setq external-format (or (external-format-from-content-type (header-in :content-type request))
 525                               (when force-text
 526                                 *hunchentoot-default-external-format*))))
 527   (let ((raw-post-data (or (slot-value request 'raw-post-data)
 528                            (get-post-data :request request :want-stream want-stream))))
 529     (cond ((typep raw-post-data 'stream) raw-post-data)
 530           ((member raw-post-data '(t nil)) nil)
 531           (external-format (octets-to-string raw-post-data :external-format external-format))
 532           (t raw-post-data))))
 533
 534 (defun aux-request-value (symbol &optional (request *request*))
 535   "Returns the value associated with SYMBOL from the request object
 536 REQUEST \(the default is the current request) if it exists.  The
 537 second return value is true if such a value was found."
 538   (when request
 539     (let ((found (assoc symbol (aux-data request) :test #'eq)))
 540       (values (cdr found) found))))
 541
 542 (defsetf aux-request-value (symbol &optional request)
 543     (new-value)
 544   "Sets the value associated with SYMBOL from the request object
 545 REQUEST \(default is *REQUEST*).  If there is already a value
 546 associated with SYMBOL it will be replaced."
 547   (with-rebinding (symbol)
 548     (with-unique-names (place %request)
 549       `(let* ((,%request (or ,request *request*))
 550               (,place (assoc ,symbol (aux-data ,%request) :test #'eq)))
 551          (cond
 552            (,place
 553             (setf (cdr ,place) ,new-value))
 554            (t
 555             (push (cons ,symbol ,new-value)
 556                   (aux-data ,%request))
 557             ,new-value))))))
 558
 559 (defun delete-aux-request-value (symbol &optional (request *request*))
 560   "Removes the value associated with SYMBOL from the request object
 561 REQUEST."
 562   (when request
 563     (setf (aux-data request)
 564             (delete symbol (aux-data request)
 565                     :key #'car :test #'eq)))
 566   (values))
 567
 568 (defun request-pathname (&optional (request *request*) drop-prefix)
 569   "Construct a relative pathname from the request's SCRIPT-NAME.
 570 If DROP-PREFIX is given, pathname construction starts at the first path
 571 segment after the prefix.
 572
 573 Returns NIL if the SCRIPT-NAME refers to a location above the
 574 DROP-PREFIX (or the root if no prefix was given)."
 575   (labels ((to-pathname (directory filename)
 576              (ppcre:register-groups-bind (name type) ("^(.*?)(?:[.]([^.]*))?$" filename)
 577                (make-pathname :name name :type type
 578                               :directory (and directory (cons :relative directory)))))
 579            (resolve-path (segments)
 580                (if (null segments)
 581                    (make-pathname)
 582                    (loop with path for (segment . rest) on segments by #'cdr do
 583                         (let ((dotdot (string= ".." segment)))
 584                           (cond ((and dotdot (or (null path) (null rest)))
 585                                  (return nil))
 586                                 (dotdot
 587                                  (pop path))
 588                                 ((null rest)
 589                                  (return (to-pathname (nreverse path) segment)))
 590                                 ((string= "" segment)
 591                                  #| skip empty segment |#)
 592                                 (t
 593                                  (push segment path))))))))
 594     (let ((segments (ppcre:split "/" (url-decode (script-name request)))))
 595       (if drop-prefix
 596           (loop for prefix-segment in (ppcre:split "/" drop-prefix)
 597                 for rest = segments then (cdr rest)
 598                 if (string/= (car rest) prefix-segment) do (return nil)
 599                 finally (return (resolve-path (cdr rest))))
 600           (resolve-path segments)))))