headers.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 (defgeneric write-header-line (key value stream)
  32   (:documentation "Accepts a string KEY and a Lisp object VALUE and
  33 writes them directly to the client as an HTTP header line.")
  34   (:method (key (string string) stream)
  35     (write-string key stream)
  36     (write-char #\: stream)
  37     (write-char #\Space stream)
  38     (let ((start 0))
  39       (loop
  40          (let ((end (or (position #\Newline string :start start)
  41                         (length string))))
  42            ;; skip empty lines, as they confuse certain HTTP clients
  43            (unless (eql start end)
  44              (unless (zerop start)
  45                (write-char #\Tab stream))
  46              (write-string string stream :start start :end end)
  47              (write-char #\Return stream)
  48              (write-char #\Linefeed stream))
  49            (setf start (1+ end))
  50            (when (<= (length string) start)
  51              (return))))))
  52   (:method (key (number number) stream)
  53     (write-header-line key (write-to-string number :escape nil :readably nil :base 10) stream))
  54   (:method (key value stream)
  55     (write-header-line key (princ-to-string value) stream)))
  56
  57 (defun maybe-add-charset-to-content-type-header (content-type external-format)
  58   "Given the contents of a CONTENT-TYPE header, add a charset=
  59   attribute describing the given EXTERNAL-FORMAT if no charset=
  60   attribute is already present and the content type is a text content
  61   type.  Returns the augmented content type."
  62   (if (and (cl-ppcre:scan "(?i)^text" content-type)
  63            (not (cl-ppcre:scan "(?i);\\s*charset=" content-type)))
  64       (format nil "~A; charset=~(~A~)" content-type (flex:external-format-name external-format))
  65       content-type))
  66
  67 (defun start-output (return-code &optional (content nil content-provided-p))
  68   "Sends all headers and maybe the content body to
  69 *HUNCHENTOOT-STREAM*.  Returns immediately and does nothing if called
  70 more than once per request.  Called by PROCESS-REQUEST and/or
  71 SEND-HEADERS.  The RETURN-CODE argument represents the integer return
  72 code of the request.  The corresponding reason phrase is determined by
  73 calling the REASON-PHRASE function.  The CONTENT provided represents
  74 the body data to send to the client, if any.  If it is not specified,
  75 no body is written to the client.  The handler function is expected to
  76 directly write to the stream in this case.
  77
  78 Returns the stream that is connected to the client."
  79   (let* ((chunkedp (and (acceptor-output-chunking-p *acceptor*)
  80                         (eq (server-protocol *request*) :http/1.1)
  81                         ;; only turn chunking on if the content
  82                         ;; length is unknown at this point...
  83                         (null (or (content-length*) content-provided-p))))
  84          (request-method (request-method *request*))
  85          (head-request-p (eq request-method :head))
  86          content-modified-p)
  87     (multiple-value-bind (keep-alive-p keep-alive-requested-p)
  88         (keep-alive-p *request*)
  89       (when keep-alive-p
  90         (setq keep-alive-p
  91               ;; use keep-alive if there's a way for the client to
  92               ;; determine when all content is sent (or if there
  93               ;; is no content)
  94               (or chunkedp
  95                   head-request-p
  96                   (eql (return-code*) +http-not-modified+)
  97                   (content-length*)
  98                   content)))
  99       ;; now set headers for keep-alive and chunking
 100       (when chunkedp
 101         (setf (header-out :transfer-encoding) "chunked"))
 102       (cond (keep-alive-p
 103              (setf *close-hunchentoot-stream* nil)
 104              (when (and (acceptor-read-timeout *acceptor*)
 105                         (or (not (eq (server-protocol *request*) :http/1.1))
 106                             keep-alive-requested-p))
 107                ;; persistent connections are implicitly assumed for
 108                ;; HTTP/1.1, but we return a 'Keep-Alive' header if the
 109                ;; client has explicitly asked for one
 110                (setf (header-out :connection) "Keep-Alive"
 111                      (header-out :keep-alive)
 112                      (format nil "timeout=~D" (acceptor-read-timeout *acceptor*)))))
 113             ((not (header-out-set-p :connection))
 114              (setf (header-out :connection) "Close"))))
 115     (unless (and (header-out-set-p :server)
 116                  (null (header-out :server)))
 117       (setf (header-out :server) (or (header-out :server)
 118                                      (acceptor-server-name *acceptor*))))
 119     (setf (header-out :date) (rfc-1123-date))
 120     (when (and (stringp content)
 121                (not content-modified-p)
 122                (starts-with-one-of-p (or (content-type*) "")
 123                                      *content-types-for-url-rewrite*))
 124       ;; if the Content-Type header starts with one of the strings
 125       ;; in *CONTENT-TYPES-FOR-URL-REWRITE* then maybe rewrite the
 126       ;; content
 127       (setq content (maybe-rewrite-urls-for-session content)))
 128     (when (stringp content)
 129       ;; if the content is a string, convert it to the proper external format
 130       (setf content (string-to-octets content :external-format (reply-external-format*))
 131             (content-type*) (maybe-add-charset-to-content-type-header (content-type*)
 132                                                                       (reply-external-format*))))
 133     (when content
 134       ;; whenever we know what we're going to send out as content, set
 135       ;; the Content-Length header properly; maybe the user specified
 136       ;; a different content length, but that will wrong anyway
 137       (setf (header-out :content-length) (length content)))
 138     ;; send headers only once
 139     (when *headers-sent*
 140       (return-from start-output))
 141     (setq *headers-sent* t)
 142     (send-response *acceptor*
 143                    *hunchentoot-stream*
 144                    return-code
 145                    :headers (headers-out*)
 146                    :cookies (cookies-out*)
 147                    :content (unless head-request-p
 148                               content))
 149     ;; when processing a HEAD request, exit to return from PROCESS-REQUEST
 150     (when head-request-p
 151       (throw 'request-processed nil))
 152     (when chunkedp
 153       ;; turn chunking on after the headers have been sent
 154       (unless (typep *hunchentoot-stream* 'chunked-stream)
 155         (setq *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)))
 156       (setf (chunked-stream-output-chunking-p *hunchentoot-stream*) t))
 157     *hunchentoot-stream*))
 158
 159 (defun send-response (acceptor stream status-code
 160                       &key headers cookies content)
 161   "Send a HTTP response to the STREAM and log the event in ACCEPTOR.
 162   STATUS-CODE is the HTTP status code used in the response.  HEADERS
 163   and COOKIES are used to create the response header.  If CONTENT is
 164   provided, it is sent as the response body.
 165
 166   If *HEADER-STREAM* is not NIL, the response headers are written to
 167   that stream when they are written to the client.
 168
 169   STREAM is returned."
 170   (when content
 171     (setf (content-length*) (length content)))
 172   (when (content-length*)
 173     (if (assoc :content-length headers)
 174         (setf (cdr (assoc :content-length headers)) (content-length*))
 175         (push (cons :content-length (content-length*)) headers)))
 176   ;; access log message
 177   (acceptor-log-access acceptor :return-code status-code)
 178   ;; Read post data to clear stream - Force binary mode to avoid OCTETS-TO-STRING overhead.
 179   (raw-post-data :force-binary t)
 180   (let* ((client-header-stream (flex:make-flexi-stream stream :external-format +latin-1+))
 181          (header-stream (if *header-stream*
 182                             (make-broadcast-stream *header-stream* client-header-stream)
 183                             client-header-stream)))
 184     ;; start with status line
 185     (format header-stream "HTTP/1.1 ~D ~A~C~C" status-code (reason-phrase status-code) #\Return #\Linefeed)
 186     ;; write all headers from the REPLY object
 187     (loop for (key . value) in headers
 188        when value
 189        do (write-header-line (as-capitalized-string key) value header-stream))
 190     ;; now the cookies
 191     (loop for (nil . cookie) in cookies
 192        do (write-header-line "Set-Cookie" (stringify-cookie cookie) header-stream))
 193     (format header-stream "~C~C" #\Return #\Linefeed))
 194   ;; now optional content
 195   (when content
 196     (write-sequence content stream)
 197     (finish-output stream))
 198   stream)
 199
 200 (defun send-headers ()
 201   "Sends the initial status line and all headers as determined by the
 202 REPLY object *REPLY*.  Returns a binary stream to which the body of
 203 the reply can be written.  Once this function has been called, further
 204 changes to *REPLY* don't have any effect.  Also, automatic handling of
 205 errors \(i.e. sending the corresponding status code to the browser,
 206 etc.) is turned off for this request.  If your handlers return the
 207 full body as a string or as an array of octets you should NOT call
 208 this function.
 209
 210 This function does not return control to the caller during HEAD
 211 request processing."
 212   (start-output (return-code*)))
 213
 214 (defun read-initial-request-line (stream)
 215   "Reads and returns the initial HTTP request line, catching permitted
 216 errors and handling *BREAK-EVEN-WHILE-READING-REQUEST-TYPE-P*.  If no
 217 request could be read, returns NIL.  At this point, both an
 218 end-of-file as well as a timeout condition are normal; end-of-file
 219 will occur when the client has decided to not send another request but
 220 to close the connection instead, a timeout indicates that the
 221 connection timeout established by Hunchentoot has expired and we do
 222 not want to wait for another request any longer."
 223   (handler-case
 224       (let ((*current-error-message* "While reading initial request line:"))
 225         (with-mapped-conditions ()
 226           (read-line* stream)))
 227     ((or end-of-file #-:lispworks usocket:timeout-error) ())))
 228
 229 (defun send-bad-request-response (stream &optional additional-info)
 230   "Send a ``Bad Request'' response to the client."
 231   (write-sequence (flex:string-to-octets
 232                    (format nil "HTTP/1.0 ~D ~A~C~CConnection: close~C~C~C~CYour request could not be interpreted by this HTTP server~C~C~@[~A~]~C~C"
 233                            +http-bad-request+ (reason-phrase +http-bad-request+) #\Return #\Linefeed
 234                            #\Return #\Linefeed #\Return #\Linefeed #\Return #\Linefeed additional-info #\Return #\Linefeed))
 235                   stream))
 236
 237 (defun printable-ascii-char-p (char)
 238   (<= 32 (char-code char) 126))
 239
 240 (defun get-request-data (stream)
 241   "Reads incoming headers from the client via STREAM.  Returns as
 242 multiple values the headers as an alist, the method, the URI, and the
 243 protocol of the request."
 244   (with-character-stream-semantics
 245    (let ((first-line (read-initial-request-line stream)))
 246      (when first-line
 247        (unless (every #'printable-ascii-char-p first-line)
 248          (send-bad-request-response stream "Non-ASCII character in request line")
 249          (return-from get-request-data nil))
 250        (destructuring-bind (&optional method url-string protocol)
 251            (split "\\s+" first-line :limit 3)
 252          (unless url-string
 253            (send-bad-request-response stream)
 254            (return-from get-request-data nil))
 255          (when *header-stream*
 256            (format *header-stream* "~A~%" first-line))
 257          (let ((headers (and protocol (read-http-headers stream *header-stream*))))
 258            (unless protocol (setq protocol "HTTP/0.9"))
 259            ;; maybe handle 'Expect: 100-continue' header
 260            (when-let (expectations (cdr (assoc* :expect headers)))
 261              (when (member "100-continue" (split "\\s*,\\s*" expectations) :test #'equalp)
 262                ;; according to 14.20 in the RFC - we should actually
 263                ;; check if we have to respond with 417 here
 264                (let ((continue-line
 265                       (format nil "HTTP/1.1 ~D ~A"
 266                               +http-continue+
 267                               (reason-phrase +http-continue+))))
 268                  (write-sequence (map 'list #'char-code continue-line) stream)
 269                  (write-sequence +crlf+ stream)
 270                  (write-sequence +crlf+ stream)
 271                  (force-output stream)
 272                  (when *header-stream*
 273                    (format *header-stream* "~A~%" continue-line)))))
 274            (values headers
 275                    (as-keyword method)
 276                    url-string
 277                    (as-keyword (trim-whitespace protocol)))))))))