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