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                                   (rfc2388:get-file-name headers)
 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.  You should not
 220 change or replace this functionality unless you know what you're
 221 doing."
 222   (catch 'request-processed ; used by HTTP HEAD handling to end request processing in a HEAD request (see START-OUTPUT)
 223     (let (*tmp-files*
 224           *headers-sent*
 225           (*request* request))
 226       (unwind-protect
 227            (with-mapped-conditions ()
 228              (labels
 229                  ((report-error-to-client (error &optional backtrace)
 230                     (when *log-lisp-errors-p*
 231                       (log-message* *lisp-errors-log-level* "~A~@[~%~A~]" error (when *log-lisp-backtraces-p*
 232                                                                                   backtrace)))
 233                     (start-output +http-internal-server-error+
 234                                   (acceptor-status-message *acceptor*
 235                                                            +http-internal-server-error+
 236                                                            :error (princ-to-string error)
 237                                                            :backtrace (princ-to-string backtrace)))))
 238                (multiple-value-bind (body error backtrace)
 239                    ;; skip dispatch if bad request
 240                    (when (eql (return-code *reply*) +http-ok+)
 241                      (catch 'handler-done
 242                        (handle-request *acceptor* *request*)))
 243                  (when error
 244                    ;; error occured in request handler
 245                    (report-error-to-client error backtrace))
 246                  (unless *headers-sent*
 247                    (handler-case
 248                        (with-debugger
 249                          (start-output (return-code *reply*)
 250                                        (or (acceptor-status-message *acceptor*
 251                                                                     (return-code *reply*))
 252                                            body)))
 253                      (error (e)
 254                        ;; error occured while writing to the client.  attempt to report.
 255                        (report-error-to-client e)))))))
 256         (dolist (path *tmp-files*)
 257           (when (and (pathnamep path) (probe-file path))
 258             ;; the handler may have chosen to (re)move the uploaded
 259             ;; file, so ignore errors that happen during deletion
 260             (ignore-errors*
 261               (delete-file path))))))))
 262
 263 (defun within-request-p ()
 264   "True if we're in the context of a request, otherwise nil."
 265   (and (boundp '*request*) *request*))
 266
 267 (defun parse-multipart-form-data (request external-format)
 268   "Parse the REQUEST body as multipart/form-data, assuming that its
 269 content type has already been verified.  Returns the form data as
 270 alist or NIL if there was no data or the data could not be parsed."
 271   (handler-case*
 272       (let ((content-stream (make-flexi-stream (content-stream request) :external-format +latin-1+)))
 273         (prog1
 274             (parse-rfc2388-form-data content-stream (header-in :content-type request) external-format)
 275           (let ((stray-data (get-post-data :already-read (flexi-stream-position content-stream))))
 276             (when (and stray-data (plusp (length stray-data)))
 277               (hunchentoot-warn "~A octets of stray data after form-data sent by client."
 278                                 (length stray-data))))))
 279     (error (condition)
 280       (log-message* :error "While parsing multipart/form-data parameters: ~A" condition)
 281       nil)))
 282
 283 (defun maybe-read-post-parameters (&key (request *request*) force external-format)
 284   "Make surce that any POST parameters in the REQUEST are parsed.  The
 285 body of the request must be either application/x-www-form-urlencoded
 286 or multipart/form-data to be considered as containing POST parameters.
 287 If FORCE is true, parsing is done unconditionally.  Otherwise, parsing
 288 will only be done if the RAW-POST-DATA slot in the REQUEST is false.
 289 EXTERNAL-FORMAT specifies the external format of the data in the
 290 request body.  By default, the encoding is determined from the
 291 Content-Type header of the request or from
 292 *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* if none is found."
 293   (when (and (header-in :content-type request)
 294              (member (request-method request) *methods-for-post-parameters* :test #'eq)
 295              (or force
 296                  (not (slot-value request 'raw-post-data)))
 297              ;; can't reparse multipart posts, even when FORCEd
 298              (not (eq t (slot-value request 'raw-post-data))))
 299     (unless (or (header-in :content-length request)
 300                 (input-chunking-p))
 301       (log-message* :warning "Can't read request body because there's ~
 302 no Content-Length header and input chunking is off.")
 303       (return-from maybe-read-post-parameters nil))
 304     (handler-case*
 305         (multiple-value-bind (type subtype charset)
 306               (parse-content-type (header-in :content-type request))
 307           (let ((external-format (or external-format
 308                                      (when charset
 309                                        (handler-case
 310                                            (make-external-format charset :eol-style :lf)
 311                                          (error ()
 312                                            (hunchentoot-warn "Ignoring ~
 313 unknown character set ~A in request content type."
 314                                                  charset))))
 315                                      *hunchentoot-default-external-format*)))
 316             (setf (slot-value request 'post-parameters)
 317                   (cond ((and (string-equal type "application")
 318                               (string-equal subtype "x-www-form-urlencoded"))
 319                          (form-url-encoded-list-to-alist
 320                           (split "&" (raw-post-data :request request :external-format +latin-1+))
 321                           external-format))
 322                         ((and (string-equal type "multipart")
 323                               (string-equal subtype "form-data"))
 324                          (prog1 (parse-multipart-form-data request external-format)
 325                            (setf (slot-value request 'raw-post-data) t)))))))
 326       (error (condition)
 327         (log-message* :error "Error when reading POST parameters from body: ~A" condition)
 328         ;; this is not the right thing to do because it could happen
 329         ;; that we aren't finished reading from the request stream and
 330         ;; can't send a reply - to be revisited
 331         (setf (return-code*) +http-bad-request+
 332               *close-hunchentoot-stream* t)
 333         (abort-request-handler)))))
 334
 335 (defun recompute-request-parameters (&key (request *request*)
 336                                           (external-format *hunchentoot-default-external-format*))
 337   "Recomputes the GET and POST parameters for the REQUEST object
 338 REQUEST.  This only makes sense if you're switching external formats
 339 during the request."
 340   (maybe-read-post-parameters :request request :force t :external-format external-format)
 341   (setf (slot-value request 'get-parameters)
 342         (form-url-encoded-list-to-alist (split "&" (query-string request)) external-format))
 343   (values))
 344
 345 (defun script-name* (&optional (request *request*))
 346   "Returns the file name of the REQUEST object REQUEST. That's the
 347 requested URI without the query string \(i.e the GET parameters)."
 348   (script-name request))
 349
 350 (defun query-string* (&optional (request *request*))
 351   "Returns the query string of the REQUEST object REQUEST. That's
 352 the part behind the question mark \(i.e. the GET parameters)."
 353   (query-string request))
 354
 355 (defun get-parameters* (&optional (request *request*))
 356   "Returns an alist of the GET parameters associated with the REQUEST
 357 object REQUEST."
 358   (get-parameters request))
 359
 360 (defmethod post-parameters :before ((request request))
 361   ;; Force here because if someone calls POST-PARAMETERS they actually
 362   ;; want them, regardless of why the RAW-POST-DATA has been filled
 363   ;; in. (For instance, if SEND-HEADERS has been called, filling in
 364   ;; RAW-POST-DATA, and then subsequent code calls POST-PARAMETERS,
 365   ;; without the :FORCE flag POST-PARAMETERS would return NIL.)
 366   (maybe-read-post-parameters
 367    :request request :force (not (slot-value request 'post-parameters))))
 368
 369 (defun post-parameters* (&optional (request *request*))
 370   "Returns an alist of the POST parameters associated with the REQUEST
 371 object REQUEST."
 372   (post-parameters request))
 373
 374 (defun headers-in* (&optional (request *request*))
 375   "Returns an alist of the incoming headers associated with the
 376 REQUEST object REQUEST."
 377   (headers-in request))
 378
 379 (defun cookies-in* (&optional (request *request*))
 380   "Returns an alist of all cookies associated with the REQUEST object
 381 REQUEST."
 382   (cookies-in request))
 383
 384 (defgeneric header-in (name request)
 385   (:documentation "Returns the incoming header with name NAME.  NAME
 386 can be a keyword \(recommended) or a string.")
 387   (:method (name request)
 388    (cdr (assoc* name (headers-in request)))))
 389
 390 (defun header-in* (name &optional (request *request*))
 391   "Returns the incoming header with name NAME.  NAME can be a keyword
 392 \(recommended) or a string."
 393   (header-in name request))
 394
 395 (defun authorization (&optional (request *request*))
 396   "Returns as two values the user and password \(if any) as encoded in
 397 the 'AUTHORIZATION' header.  Returns NIL if there is no such header."
 398   (let* ((authorization (header-in :authorization request))
 399          (start (and authorization
 400                      (> (length authorization) 5)
 401                      (string-equal "Basic" authorization :end2 5)
 402                      (scan "\\S" authorization :start 5))))
 403     (when start
 404       (destructuring-bind (&optional user password)
 405           (split ":" (base64:base64-string-to-string (subseq authorization start)))
 406         (values user password)))))
 407
 408 (defun remote-addr* (&optional (request *request*))
 409   "Returns the address the current request originated from."
 410   (remote-addr request))
 411
 412 (defun remote-port* (&optional (request *request*))
 413   "Returns the port the current request originated from."
 414   (remote-port request))
 415
 416 (defun local-addr* (&optional (request *request*))
 417   "Returns the address the current request connected to."
 418   (local-addr request))
 419
 420 (defun local-port* (&optional (request *request*))
 421   "Returns the port the current request connected to."
 422   (local-port request))
 423
 424 (defun real-remote-addr (&optional (request *request*))
 425   "Returns the 'X-Forwarded-For' incoming http header as the
 426 second value in the form of a list of IP addresses and the first
 427 element of this list as the first value if this header exists.
 428 Otherwise returns the value of REMOTE-ADDR as the only value."
 429   (let ((x-forwarded-for (header-in :x-forwarded-for request)))
 430     (cond (x-forwarded-for (let ((addresses (split "\\s*,\\s*" x-forwarded-for)))
 431                              (values (first addresses) addresses)))
 432           (t (remote-addr request)))))
 433
 434 (defun host (&optional (request *request*))
 435   "Returns the 'Host' incoming http header value."
 436   (header-in :host request))
 437
 438 (defun request-uri* (&optional (request *request*))
 439   "Returns the request URI."
 440   (request-uri request))
 441
 442 (defun request-method* (&optional (request *request*))
 443   "Returns the request method as a Lisp keyword."
 444   (request-method request))
 445
 446 (defun server-protocol* (&optional (request *request*))
 447   "Returns the request protocol as a Lisp keyword."
 448   (server-protocol request))
 449
 450 (defun user-agent (&optional (request *request*))
 451   "Returns the 'User-Agent' http header."
 452   (header-in :user-agent request))
 453
 454 (defun cookie-in (name &optional (request *request*))
 455   "Returns the cookie with the name NAME \(a string) as sent by the
 456 browser - or NIL if there is none."
 457   (cdr (assoc name (cookies-in request) :test #'string=)))
 458
 459 (defun referer (&optional (request *request*))
 460   "Returns the 'Referer' \(sic!) http header."
 461   (header-in :referer request))
 462
 463 (defun get-parameter (name &optional (request *request*))
 464   "Returns the GET parameter with name NAME \(a string) - or NIL if
 465 there is none.  Search is case-sensitive."
 466   (cdr (assoc name (get-parameters request) :test #'string=)))
 467
 468 (defun post-parameter (name &optional (request *request*))
 469   "Returns the POST parameter with name NAME \(a string) - or NIL if
 470 there is none.  Search is case-sensitive."
 471   (cdr (assoc name (post-parameters request) :test #'string=)))
 472
 473 (defun parameter (name &optional (request *request*))
 474   "Returns the GET or the POST parameter with name NAME \(a string) -
 475 or NIL if there is none.  If both a GET and a POST parameter with the
 476 same name exist the GET parameter is returned.  Search is
 477 case-sensitive."
 478   (or (get-parameter name request)
 479       (post-parameter name request)))
 480
 481 (defun handle-if-modified-since (time &optional (request *request*))
 482   "Handles the 'If-Modified-Since' header of REQUEST.  The date string
 483 is compared to the one generated from the supplied universal time
 484 TIME."
 485   (let ((if-modified-since (header-in :if-modified-since request))
 486         (time-string (rfc-1123-date time)))
 487     ;; simple string comparison is sufficient; see RFC 2616 14.25
 488     (when (and if-modified-since
 489                (equal if-modified-since time-string))
 490       (setf (return-code*) +http-not-modified+)
 491       (abort-request-handler))
 492     (values)))
 493
 494 (defun external-format-from-content-type (content-type)
 495   "Creates and returns an external format corresponding to the value
 496 of the content type header provided in CONTENT-TYPE.  If the content
 497 type was not set or if the character set specified was invalid, NIL is
 498 returned."
 499   (when content-type
 500     (when-let (charset (nth-value 2 (parse-content-type content-type)))
 501       (handler-case
 502           (make-external-format (as-keyword charset) :eol-style :lf)
 503         (error ()
 504           (hunchentoot-warn "Invalid character set ~S in request has been ignored."
 505                             charset))))))
 506
 507 (defun raw-post-data (&key (request *request*) external-format force-text force-binary want-stream)
 508   "Returns the content sent by the client if there was any \(unless
 509 the content type was \"multipart/form-data\").  By default, the result
 510 is a string if the type of the `Content-Type' media type is \"text\",
 511 and a vector of octets otherwise.  In the case of a string, the
 512 external format to be used to decode the content will be determined
 513 from the `charset' parameter sent by the client \(or otherwise
 514 *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* will be used).
 515
 516 You can also provide an external format explicitly \(through
 517 EXTERNAL-FORMAT) in which case the result will unconditionally be a
 518 string.  Likewise, you can provide a true value for FORCE-TEXT which
 519 will force Hunchentoot to act as if the type of the media type had
 520 been \"text\".  Or you can provide a true value for FORCE-BINARY which
 521 means that you want a vector of octets at any rate.
 522
 523 If, however, you provide a true value for WANT-STREAM, the other
 524 parameters are ignored and you'll get the content \(flexi) stream to
 525 read from it yourself.  It is then your responsibility to read the
 526 correct amount of data, because otherwise you won't be able to return
 527 a response to the client.  If the content type of the request was
 528 `multipart/form-data' or `application/x-www-form-urlencoded', the
 529 content has been read by Hunchentoot already and you can't read from
 530 the stream anymore.
 531
 532 You can call RAW-POST-DATA more than once per request, but you can't
 533 mix calls which have different values for WANT-STREAM.
 534
 535 Note that this function is slightly misnamed because a client can send
 536 content even if the request method is not POST."
 537   (when (and force-binary force-text)
 538     (parameter-error "It doesn't make sense to set both FORCE-BINARY and FORCE-TEXT to a true value."))
 539   (unless (or external-format force-binary)
 540     (setq external-format (or (external-format-from-content-type (header-in :content-type request))
 541                               (when force-text
 542                                 *hunchentoot-default-external-format*))))
 543   (let ((raw-post-data (or (slot-value request 'raw-post-data)
 544                            (get-post-data :request request :want-stream want-stream))))
 545     (cond ((typep raw-post-data 'stream) raw-post-data)
 546           ((member raw-post-data '(t nil)) nil)
 547           (external-format (octets-to-string raw-post-data :external-format external-format))
 548           (t raw-post-data))))
 549
 550 (defun aux-request-value (symbol &optional (request *request*))
 551   "Returns the value associated with SYMBOL from the request object
 552 REQUEST \(the default is the current request) if it exists.  The
 553 second return value is true if such a value was found."
 554   (when request
 555     (let ((found (assoc symbol (aux-data request) :test #'eq)))
 556       (values (cdr found) found))))
 557
 558 (defsetf aux-request-value (symbol &optional request)
 559     (new-value)
 560   "Sets the value associated with SYMBOL from the request object
 561 REQUEST \(default is *REQUEST*).  If there is already a value
 562 associated with SYMBOL it will be replaced."
 563   (with-rebinding (symbol)
 564     (with-unique-names (place %request)
 565       `(let* ((,%request (or ,request *request*))
 566               (,place (assoc ,symbol (aux-data ,%request) :test #'eq)))
 567          (cond
 568            (,place
 569             (setf (cdr ,place) ,new-value))
 570            (t
 571             (push (cons ,symbol ,new-value)
 572                   (aux-data ,%request))
 573             ,new-value))))))
 574
 575 (defun delete-aux-request-value (symbol &optional (request *request*))
 576   "Removes the value associated with SYMBOL from the request object
 577 REQUEST."
 578   (when request
 579     (setf (aux-data request)
 580             (delete symbol (aux-data request)
 581                     :key #'car :test #'eq)))
 582   (values))
 583
 584 (defun parse-path (path)
 585   "Return a relative pathname that has been verified to not contain
 586   any directory traversals or explicit device or host fields.  Returns
 587   NIL if the path is not acceptable."
 588   (when (every #'graphic-char-p path)
 589     (let* ((pathname (pathname (remove #\\ (regex-replace "^/*" path ""))))
 590            (directory (pathname-directory pathname)))
 591       (when (and (or (null (pathname-host pathname))
 592                      (equal (pathname-host pathname) (pathname-host *default-pathname-defaults*)))
 593                  (or (null (pathname-device pathname))
 594                      (equal (pathname-device pathname) (pathname-device *default-pathname-defaults*)))
 595                  (or (null directory)
 596                      (and (eql (first directory) :relative)
 597                           (every #'stringp (rest directory))))) ; only string components, no :UP traversals
 598         pathname))))
 599
 600 (defun request-pathname (&optional (request *request*) drop-prefix)
 601   "Construct a relative pathname from the request's SCRIPT-NAME.
 602 If DROP-PREFIX is given, pathname construction starts at the first path
 603 segment after the prefix.
 604 "
 605   (let ((path (url-decode (script-name request))))
 606     (if drop-prefix
 607         (when (starts-with-p path drop-prefix)
 608           (parse-path (subseq path (length drop-prefix))))
 609         (parse-path path))))