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