;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/hunchentoot/headers.lisp,v 1.29 2008/03/27 08:08:31 edi Exp $ ;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :hunchentoot) (defun maybe-write-to-header-stream (key &optional value) "Accepts a string KEY and an optional Lisp object VALUE and writes them directly to the character stream *HEADER-STREAM* as an HTTP header line \(or as a simple line if VALUE is NIL)." (when *header-stream* (format *header-stream* "~A~@[: ~A~]~%" key (and value (regex-replace-all "[\\r\\n]" value " "))) (force-output *header-stream*))) (defgeneric write-header-line (key value) (:documentation "Accepts a string KEY and a Lisp object VALUE and writes them directly to the client as an HTTP header line.") (:method (key (string string)) (let ((stream *hunchentoot-stream*)) (labels ((write-header-char (char) (when *header-stream* (write-char char *header-stream*)) (write-byte (char-code char) stream)) (write-header-string (string &key (start 0) (end (length string))) (loop for i from start below end do (write-header-char (aref string i))))) (write-header-string key) (write-header-char #\:) (write-header-char #\Space) (let ((start 0)) (loop (let ((end (or (position #\Newline string :start start) (length string)))) ;; skip empty lines, as they confuse certain HTTP clients (unless (eql start end) (unless (zerop start) (write-header-char #\Tab)) (write-header-string string :start start :end end) (write-header-char #\Return) (write-header-char #\Linefeed)) (setf start (1+ end)) (when (<= (length string) start) (return)))))))) (:method (key value) (write-header-line key (princ-to-string value)))) #-with-step-instrumentation (defmacro with-step-instrumentation ((report-label) &body body) (declare (ignore report-label)) `(macrolet ((note-step (name) (declare (ignore name)))) ,@body)) #+with-step-instrumentation (defmacro with-step-instrumentation ((report-label) &body body) (with-unique-names (start-time stamps) `(let ((,start-time (prof::get-real-time)) ,stamps) (macrolet ((note-step (name) `(push (cons ',name (prof::get-real-time)) ,',stamps))) (multiple-value-prog1 (progn ,@body) (format *trace-output* "step instrumentation for ~A~%" ,report-label) (dolist (stamp (nreverse ,stamps)) (format *trace-output* "~A ~A~%" (car stamp) (prof::format-time (- (cdr stamp) ,start-time))))))))) (defun start-output (&optional (content nil content-provided-p)) "Sends all headers and maybe the content body to *HUNCHENTOOT-STREAM*. Returns immediately and does nothing if called more than once per request. Handles the supported return codes accordingly. Called by PROCESS-REQUEST and/or SEND-HEADERS. Returns the stream to write to." ;; send headers only once (when *headers-sent* (return-from start-output)) (setq *headers-sent* t) ;; Read post data to clear stream - Force binary mode to avoid OCTETS-TO-STRING overhead. (raw-post-data :force-binary t) (let* ((return-code (return-code)) (chunkedp (and (server-output-chunking-p *server*) (eq (server-protocol) :http/1.1) ;; only turn chunking on if the content ;; length is unknown at this point... (null (or (content-length) content-provided-p)) ;; ...AND if the return code isn't one where ;; Hunchentoot (or a user error handler) sends its ;; own content (member return-code *approved-return-codes*))) (reason-phrase (reason-phrase return-code)) (request-method (request-method)) (head-request-p (eq request-method :head)) content-modified-p) (multiple-value-bind (keep-alive-p keep-alive-requested-p) (keep-alive-p) (when keep-alive-p (setq keep-alive-p ;; use keep-alive if there's a way for the client to ;; determine when all content is sent (or if there ;; is no content) (or chunkedp head-request-p (eql (return-code) +http-not-modified+) (content-length) content))) ;; now set headers for keep-alive and chunking (when chunkedp (setf (header-out :transfer-encoding) "chunked")) (cond (keep-alive-p (setf *close-hunchentoot-stream* nil) (when (and (server-read-timeout *server*) (or (not (eq (server-protocol) :http/1.1)) keep-alive-requested-p)) ;; persistent connections are implicitly assumed for ;; HTTP/1.1, but we return a 'Keep-Alive' header if the ;; client has explicitly asked for one (setf (header-out :connection) "Keep-Alive" (header-out :keep-alive) (format nil "timeout=~D" (server-read-timeout *server*))))) (t (setf (header-out :connection) "Close")))) (unless (and (header-out-set-p :server) (null (header-out :server))) (setf (header-out :server) (or (header-out :server) (server-name-header)))) (setf (header-out :date) (rfc-1123-date)) (unless reason-phrase (setq content (escape-for-html (format nil "Unknown http return code: ~A" return-code)) content-modified-p t return-code +http-internal-server-error+ reason-phrase (reason-phrase return-code))) (unless (or (not *handle-http-errors-p*) (member return-code *approved-return-codes*)) ;; call error handler, if any - should return NIL if it can't ;; handle the error (let (error-handled-p) (when *http-error-handler* (setq error-handled-p (funcall *http-error-handler* return-code) content (or error-handled-p content) content-modified-p (or content-modified-p error-handled-p))) ;; handle common return codes other than 200, which weren't ;; handled by the error handler (unless error-handled-p (setf (content-type) "text/html; charset=iso-8859-1" content-modified-p t content (format nil "