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 *finish-processing-socket* 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 (unless (header-out :connection) ; allowing for handler overriding
111 (setf (header-out :connection) "Keep-Alive"))
112 (setf (header-out :keep-alive)
113 (format nil "timeout=~D" (acceptor-read-timeout *acceptor*)))))
114 ((not (header-out-set-p :connection))
115 (setf (header-out :connection) "Close"))))
116 (unless (and (header-out-set-p :server)
117 (null (header-out :server)))
118 (setf (header-out :server) (or (header-out :server)
119 (acceptor-server-name *acceptor*))))
120 (setf (header-out :date) (rfc-1123-date))
121 (when (and (stringp content)
122 (not content-modified-p)
123 (starts-with-one-of-p (or (content-type*) "")
124 *content-types-for-url-rewrite*))
125 ;; if the Content-Type header starts with one of the strings
126 ;; in *CONTENT-TYPES-FOR-URL-REWRITE* then maybe rewrite the
127 ;; content
128 (setq content (maybe-rewrite-urls-for-session content)))
129 (when (stringp content)
130 ;; if the content is a string, convert it to the proper external format
131 (setf content (string-to-octets content :external-format (reply-external-format*))
132 (content-type*) (maybe-add-charset-to-content-type-header (content-type*)
133 (reply-external-format*))))
134 (when content
135 ;; whenever we know what we're going to send out as content, set
136 ;; the Content-Length header properly; maybe the user specified
137 ;; a different content length, but that will wrong anyway
138 (setf (header-out :content-length) (length content)))
139 ;; send headers only once
140 (when *headers-sent*
141 (return-from start-output))
142 (setq *headers-sent* t)
143 (send-response *acceptor*
144 *hunchentoot-stream*
145 return-code
146 :headers (headers-out*)
147 :cookies (cookies-out*)
148 :content (unless head-request-p
149 content))
150 ;; when processing a HEAD request, exit to return from PROCESS-REQUEST
151 (when head-request-p
152 (throw 'request-processed nil))
153 (when chunkedp
154 ;; turn chunking on after the headers have been sent
155 (unless (typep *hunchentoot-stream* 'chunked-stream)
156 (setq *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)))
157 (setf (chunked-stream-output-chunking-p *hunchentoot-stream*) t))
158 *hunchentoot-stream*))
159
160 (defun send-response (acceptor stream status-code
161 &key headers cookies content)
162 "Send a HTTP response to the STREAM and log the event in ACCEPTOR.
163 STATUS-CODE is the HTTP status code used in the response. HEADERS
164 and COOKIES are used to create the response header. If CONTENT is
165 provided, it is sent as the response body.
166
167 If *HEADER-STREAM* is not NIL, the response headers are written to
168 that stream when they are written to the client.
169
170 STREAM is returned."
171 (when content
172 (setf (content-length*) (length content)))
173 (when (content-length*)
174 (if (assoc :content-length headers)
175 (setf (cdr (assoc :content-length headers)) (content-length*))
176 (push (cons :content-length (content-length*)) headers)))
177 ;; access log message
178 (acceptor-log-access acceptor :return-code status-code)
179 ;; Read post data to clear stream - Force binary mode to avoid OCTETS-TO-STRING overhead.
180 (raw-post-data :force-binary t)
181 (let* ((client-header-stream (flex:make-flexi-stream stream :external-format +latin-1+))
182 (header-stream (if *header-stream*
183 (make-broadcast-stream *header-stream* client-header-stream)
184 client-header-stream)))
185 ;; start with status line
186 (format header-stream "HTTP/1.1 ~D ~A~C~C" status-code (reason-phrase status-code) #\Return #\Linefeed)
187 ;; write all headers from the REPLY object
188 (loop for (key . value) in headers
189 when value
190 do (write-header-line (as-capitalized-string key) value header-stream))
191 ;; now the cookies
192 (loop for (nil . cookie) in cookies
193 do (write-header-line "Set-Cookie" (stringify-cookie cookie) header-stream))
194 (format header-stream "~C~C" #\Return #\Linefeed))
195 ;; now optional content
196 (when content
197 (write-sequence content stream)
198 (finish-output stream))
199 stream)
200
201 (defun send-headers ()
202 "Sends the initial status line and all headers as determined by the
203 REPLY object *REPLY*. Returns a binary stream to which the body of
204 the reply can be written. Once this function has been called, further
205 changes to *REPLY* don't have any effect. Also, automatic handling of
206 errors \(i.e. sending the corresponding status code to the browser,
207 etc.) is turned off for this request. If your handlers return the
208 full body as a string or as an array of octets you should NOT call
209 this function.
210
211 This function does not return control to the caller during HEAD
212 request processing."
213 (start-output (return-code*)))
214
215 (defun read-initial-request-line (stream)
216 "Reads and returns the initial HTTP request line, catching permitted
217 errors and handling *BREAK-EVEN-WHILE-READING-REQUEST-TYPE-P*. If no
218 request could be read, returns NIL. At this point, both an
219 end-of-file as well as a timeout condition are normal; end-of-file
220 will occur when the client has decided to not send another request but
221 to close the connection instead, a timeout indicates that the
222 connection timeout established by Hunchentoot has expired and we do
223 not want to wait for another request any longer."
224 (handler-case
225 (let ((*current-error-message* "While reading initial request line:"))
226 (with-mapped-conditions ()
227 (read-line* stream)))
228 ((or end-of-file #-:lispworks usocket:timeout-error) ())))
229
230 (defun send-bad-request-response (stream &optional additional-info)
231 "Send a ``Bad Request'' response to the client."
232 (write-sequence (flex:string-to-octets
233 (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"
234 +http-bad-request+ (reason-phrase +http-bad-request+) #\Return #\Linefeed
235 #\Return #\Linefeed #\Return #\Linefeed #\Return #\Linefeed additional-info #\Return #\Linefeed))
236 stream))
237
238 (defun printable-ascii-char-p (char)
239 (<= 32 (char-code char) 126))
240
241 (defun get-request-data (stream)
242 "Reads incoming headers from the client via STREAM. Returns as
243 multiple values the headers as an alist, the method, the URI, and the
244 protocol of the request."
245 (with-character-stream-semantics
246 (let ((first-line (read-initial-request-line stream)))
247 (when first-line
248 (unless (every #'printable-ascii-char-p first-line)
249 (send-bad-request-response stream "Non-ASCII character in request line")
250 (return-from get-request-data nil))
251 (destructuring-bind (&optional method url-string protocol)
252 (split "\\s+" first-line :limit 3)
253 (unless url-string
254 (send-bad-request-response stream)
255 (return-from get-request-data nil))
256 (when *header-stream*
257 (format *header-stream* "~A~%" first-line))
258 (let ((headers (and protocol (read-http-headers stream *header-stream*))))
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 (if protocol
278 (as-keyword (trim-whitespace protocol))
279 :http/0.9))))))))