Commit | Line | Data |
---|---|---|
a9eeb2f4 AW |
1 | ;;; HTTP response objects |
2 | ||
2ac3c0a5 | 3 | ;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. |
a9eeb2f4 AW |
4 | |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
18 | ;; 02110-1301 USA | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (web response) | |
23 | #:use-module (rnrs bytevectors) | |
6854c324 | 24 | #:use-module (ice-9 binary-ports) |
a9eeb2f4 | 25 | #:use-module (ice-9 rdelim) |
75d6c59f | 26 | #:use-module (ice-9 match) |
a9eeb2f4 AW |
27 | #:use-module (srfi srfi-9) |
28 | #:use-module (web http) | |
29 | #:export (response? | |
30 | response-version | |
31 | response-code | |
32 | response-reason-phrase | |
33 | response-headers | |
34 | response-port | |
35 | read-response | |
36 | build-response | |
c6371902 | 37 | adapt-response-version |
a9eeb2f4 AW |
38 | write-response |
39 | ||
164a78b3 | 40 | response-must-not-include-body? |
75d6c59f | 41 | response-body-port |
3475fbb5 AW |
42 | read-response-body |
43 | write-response-body | |
a9eeb2f4 AW |
44 | |
45 | ;; General headers | |
46 | ;; | |
47 | response-cache-control | |
48 | response-connection | |
49 | response-date | |
50 | response-pragma | |
51 | response-trailer | |
52 | response-transfer-encoding | |
53 | response-upgrade | |
54 | response-via | |
55 | response-warning | |
56 | ||
57 | ;; Entity headers | |
58 | ;; | |
59 | response-allow | |
60 | response-content-encoding | |
61 | response-content-language | |
62 | response-content-length | |
63 | response-content-location | |
64 | response-content-md5 | |
65 | response-content-range | |
66 | response-content-type | |
ee2d8741 | 67 | text-content-type? |
a9eeb2f4 AW |
68 | response-expires |
69 | response-last-modified | |
70 | ||
71 | ;; Response headers | |
72 | ;; | |
73 | response-accept-ranges | |
74 | response-age | |
75 | response-etag | |
76 | response-location | |
77 | response-proxy-authenticate | |
78 | response-retry-after | |
79 | response-server | |
80 | response-vary | |
81 | response-www-authenticate)) | |
82 | ||
83 | ||
84 | (define-record-type <response> | |
85 | (make-response version code reason-phrase headers port) | |
86 | response? | |
87 | (version response-version) | |
88 | (code response-code) | |
89 | (reason-phrase %response-reason-phrase) | |
90 | (headers response-headers) | |
91 | (port response-port)) | |
92 | ||
93 | (define (bad-response message . args) | |
94 | (throw 'bad-response message args)) | |
95 | ||
e2d4bfea AW |
96 | (define (non-negative-integer? n) |
97 | (and (number? n) (>= n 0) (exact? n) (integer? n))) | |
98 | ||
99 | (define (validate-headers headers) | |
100 | (if (pair? headers) | |
101 | (let ((h (car headers))) | |
102 | (if (pair? h) | |
103 | (let ((k (car h)) (v (cdr h))) | |
be1be3e5 AW |
104 | (if (valid-header? k v) |
105 | (validate-headers (cdr headers)) | |
106 | (bad-response "Bad value for header ~a: ~s" k v))) | |
e2d4bfea AW |
107 | (bad-response "Header not a pair: ~a" h))) |
108 | (if (not (null? headers)) | |
109 | (bad-response "Headers not a list: ~a" headers)))) | |
110 | ||
a9eeb2f4 | 111 | (define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase |
e2d4bfea | 112 | (headers '()) port (validate-headers? #t)) |
06883ae0 | 113 | "Construct an HTTP response object. If VALIDATE-HEADERS? is true, |
cc1e26c2 | 114 | the headers are each run through their respective validators." |
e2d4bfea AW |
115 | (cond |
116 | ((not (and (pair? version) | |
117 | (non-negative-integer? (car version)) | |
118 | (non-negative-integer? (cdr version)))) | |
119 | (bad-response "Bad version: ~a" version)) | |
120 | ((not (and (non-negative-integer? code) (< code 600))) | |
121 | (bad-response "Bad code: ~a" code)) | |
122 | ((and reason-phrase (not (string? reason-phrase))) | |
123 | (bad-response "Bad reason phrase" reason-phrase)) | |
124 | (else | |
125 | (if validate-headers? | |
126 | (validate-headers headers)))) | |
a9eeb2f4 AW |
127 | (make-response version code reason-phrase headers port)) |
128 | ||
129 | (define *reason-phrases* | |
130 | '((100 . "Continue") | |
131 | (101 . "Switching Protocols") | |
132 | (200 . "OK") | |
133 | (201 . "Created") | |
134 | (202 . "Accepted") | |
135 | (203 . "Non-Authoritative Information") | |
136 | (204 . "No Content") | |
137 | (205 . "Reset Content") | |
138 | (206 . "Partial Content") | |
139 | (300 . "Multiple Choices") | |
140 | (301 . "Moved Permanently") | |
141 | (302 . "Found") | |
142 | (303 . "See Other") | |
143 | (304 . "Not Modified") | |
144 | (305 . "Use Proxy") | |
145 | (307 . "Temporary Redirect") | |
146 | (400 . "Bad Request") | |
147 | (401 . "Unauthorized") | |
148 | (402 . "Payment Required") | |
149 | (403 . "Forbidden") | |
150 | (404 . "Not Found") | |
151 | (405 . "Method Not Allowed") | |
152 | (406 . "Not Acceptable") | |
153 | (407 . "Proxy Authentication Required") | |
154 | (408 . "Request Timeout") | |
155 | (409 . "Conflict") | |
156 | (410 . "Gone") | |
157 | (411 . "Length Required") | |
158 | (412 . "Precondition Failed") | |
159 | (413 . "Request Entity Too Large") | |
160 | (414 . "Request-URI Too Long") | |
161 | (415 . "Unsupported Media Type") | |
162 | (416 . "Requested Range Not Satisfiable") | |
163 | (417 . "Expectation Failed") | |
164 | (500 . "Internal Server Error") | |
165 | (501 . "Not Implemented") | |
166 | (502 . "Bad Gateway") | |
167 | (503 . "Service Unavailable") | |
168 | (504 . "Gateway Timeout") | |
169 | (505 . "HTTP Version Not Supported"))) | |
170 | ||
171 | (define (code->reason-phrase code) | |
172 | (or (assv-ref *reason-phrases* code) | |
173 | "(Unknown)")) | |
174 | ||
175 | (define (response-reason-phrase response) | |
06883ae0 | 176 | "Return the reason phrase given in RESPONSE, or the standard |
cc1e26c2 | 177 | reason phrase for the response's code." |
a9eeb2f4 AW |
178 | (or (%response-reason-phrase response) |
179 | (code->reason-phrase (response-code response)))) | |
180 | ||
ee2d8741 LC |
181 | (define (text-content-type? type) |
182 | "Return #t if TYPE, a symbol as returned by `response-content-type', | |
183 | represents a textual type such as `text/plain'." | |
184 | (let ((type (symbol->string type))) | |
185 | (or (string-prefix? "text/" type) | |
186 | (string-suffix? "/xml" type) | |
187 | (string-suffix? "+xml" type)))) | |
188 | ||
a9eeb2f4 | 189 | (define (read-response port) |
06883ae0 | 190 | "Read an HTTP response from PORT. |
cc1e26c2 | 191 | |
06883ae0 | 192 | As a side effect, sets the encoding on PORT to |
cc1e26c2 AW |
193 | ISO-8859-1 (latin-1), so that reading one character reads one byte. See |
194 | the discussion of character sets in \"HTTP Responses\" in the manual, | |
195 | for more information." | |
a9eeb2f4 AW |
196 | (set-port-encoding! port "ISO-8859-1") |
197 | (call-with-values (lambda () (read-response-line port)) | |
198 | (lambda (version code reason-phrase) | |
199 | (make-response version code reason-phrase (read-headers port) port)))) | |
200 | ||
c6371902 | 201 | (define (adapt-response-version response version) |
cc1e26c2 AW |
202 | "Adapt the given response to a different HTTP version. Returns a new |
203 | HTTP response. | |
204 | ||
205 | The idea is that many applications might just build a response for the | |
206 | default HTTP version, and this method could handle a number of | |
207 | programmatic transformations to respond to older HTTP versions (0.9 and | |
208 | 1.0). But currently this function is a bit heavy-handed, just updating | |
209 | the version field." | |
c6371902 AW |
210 | (build-response #:code (response-code response) |
211 | #:version version | |
212 | #:headers (response-headers response) | |
213 | #:port (response-port response))) | |
214 | ||
a9eeb2f4 | 215 | (define (write-response r port) |
06883ae0 | 216 | "Write the given HTTP response to PORT. |
cc1e26c2 | 217 | |
06883ae0 DH |
218 | Returns a new response, whose ‘response-port’ will continue writing |
219 | on PORT, perhaps using some transfer encoding." | |
a9eeb2f4 AW |
220 | (write-response-line (response-version r) (response-code r) |
221 | (response-reason-phrase r) port) | |
222 | (write-headers (response-headers r) port) | |
223 | (display "\r\n" port) | |
224 | (if (eq? port (response-port r)) | |
225 | r | |
226 | (make-response (response-version r) (response-code r) | |
227 | (response-reason-phrase r) (response-headers r) port))) | |
228 | ||
164a78b3 | 229 | (define (response-must-not-include-body? r) |
06883ae0 | 230 | "Returns ‘#t’ if the response R is not permitted to have a body. |
164a78b3 AW |
231 | |
232 | This is true for some response types, like those with code 304." | |
233 | ;; RFC 2616, section 4.3. | |
234 | (or (<= 100 (response-code r) 199) | |
235 | (= (response-code r) 204) | |
236 | (= (response-code r) 304))) | |
237 | ||
75d6c59f LC |
238 | (define (make-delimited-input-port port len keep-alive?) |
239 | "Return an input port that reads from PORT, and makes sure that | |
240 | exactly LEN bytes are available from PORT. Closing the returned port | |
241 | closes PORT, unless KEEP-ALIVE? is true." | |
242 | (define bytes-read 0) | |
243 | ||
244 | (define (fail) | |
245 | (bad-response "EOF while reading response body: ~a bytes of ~a" | |
246 | bytes-read len)) | |
247 | ||
248 | (define (read! bv start count) | |
249 | (let ((ret (get-bytevector-n! port bv start count))) | |
250 | (if (eof-object? ret) | |
251 | (if (= bytes-read len) | |
252 | 0 | |
253 | (fail)) | |
254 | (begin | |
255 | (set! bytes-read (+ bytes-read ret)) | |
256 | (if (> bytes-read len) | |
257 | (fail) | |
258 | ret))))) | |
259 | ||
260 | (define close | |
261 | (and (not keep-alive?) | |
262 | (lambda () | |
263 | (close port)))) | |
264 | ||
265 | (make-custom-binary-input-port "delimited input port" read! #f #f close)) | |
266 | ||
267 | (define* (response-body-port r #:key (decode? #t) (keep-alive? #t)) | |
268 | "Return an input port from which the body of R can be read. The | |
269 | encoding of the returned port is set according to R's ‘content-type’ | |
dc871261 DH |
270 | header, when it's textual, except if DECODE? is ‘#f’. Return #f when |
271 | no body is available. | |
75d6c59f | 272 | |
dc871261 | 273 | When KEEP-ALIVE? is ‘#f’, closing the returned port also closes R's |
75d6c59f LC |
274 | response port." |
275 | (define port | |
84dfde82 JE |
276 | (cond |
277 | ((member '(chunked) (response-transfer-encoding r)) | |
278 | (make-chunked-input-port (response-port r) | |
279 | #:keep-alive? keep-alive?)) | |
280 | ((response-content-length r) | |
281 | => (lambda (len) | |
282 | (make-delimited-input-port (response-port r) | |
283 | len keep-alive?))) | |
284 | ((response-must-not-include-body? r) | |
285 | #f) | |
286 | ((or (memq 'close (response-connection r)) | |
287 | (and (equal? (response-version r) '(1 . 0)) | |
288 | (not (memq 'keep-alive (response-connection r))))) | |
289 | (response-port r)) | |
290 | (else | |
291 | ;; Here we have a message with no transfer encoding, no | |
292 | ;; content-length, and a response that won't necessarily be closed | |
293 | ;; by the server. Not much we can do; assume that the client | |
294 | ;; knows how to handle it. | |
295 | (response-port r)))) | |
75d6c59f LC |
296 | |
297 | (when (and decode? port) | |
298 | (match (response-content-type r) | |
299 | (((? text-content-type?) . props) | |
300 | (set-port-encoding! port | |
301 | (or (assq-ref props 'charset) | |
302 | "ISO-8859-1"))) | |
303 | (_ #f))) | |
304 | ||
305 | port) | |
306 | ||
3475fbb5 | 307 | (define (read-response-body r) |
06883ae0 DH |
308 | "Reads the response body from R, as a bytevector. Returns |
309 | ‘#f’ if there was no response body." | |
2ac3c0a5 AW |
310 | (let ((body (and=> (response-body-port r #:decode? #f) |
311 | get-bytevector-all))) | |
312 | ;; Reading a body of length 0 will result in get-bytevector-all | |
313 | ;; returning the EOF object. | |
314 | (if (eof-object? body) | |
315 | #vu8() | |
316 | body))) | |
a9eeb2f4 | 317 | |
3475fbb5 | 318 | (define (write-response-body r bv) |
06883ae0 DH |
319 | "Write BV, a bytevector, to the port corresponding to the HTTP |
320 | response R." | |
a9eeb2f4 AW |
321 | (put-bytevector (response-port r) bv)) |
322 | ||
323 | (define-syntax define-response-accessor | |
324 | (lambda (x) | |
325 | (syntax-case x () | |
326 | ((_ field) | |
327 | #'(define-response-accessor field #f)) | |
328 | ((_ field def) (identifier? #'field) | |
329 | #`(define* (#,(datum->syntax | |
330 | #'field | |
331 | (symbol-append 'response- (syntax->datum #'field))) | |
332 | response | |
333 | #:optional (default def)) | |
334 | (cond | |
335 | ((assq 'field (response-headers response)) => cdr) | |
336 | (else default))))))) | |
337 | ||
338 | ;; General headers | |
339 | ;; | |
340 | (define-response-accessor cache-control '()) | |
341 | (define-response-accessor connection '()) | |
342 | (define-response-accessor date #f) | |
343 | (define-response-accessor pragma '()) | |
344 | (define-response-accessor trailer '()) | |
345 | (define-response-accessor transfer-encoding '()) | |
346 | (define-response-accessor upgrade '()) | |
347 | (define-response-accessor via '()) | |
348 | (define-response-accessor warning '()) | |
349 | ||
350 | ;; Entity headers | |
351 | ;; | |
352 | (define-response-accessor allow '()) | |
353 | (define-response-accessor content-encoding '()) | |
354 | (define-response-accessor content-language '()) | |
355 | (define-response-accessor content-length #f) | |
356 | (define-response-accessor content-location #f) | |
357 | (define-response-accessor content-md5 #f) | |
358 | (define-response-accessor content-range #f) | |
359 | (define-response-accessor content-type #f) | |
360 | (define-response-accessor expires #f) | |
361 | (define-response-accessor last-modified #f) | |
362 | ||
363 | ;; Response headers | |
364 | ;; | |
365 | (define-response-accessor accept-ranges #f) | |
366 | (define-response-accessor age #f) | |
367 | (define-response-accessor etag #f) | |
368 | (define-response-accessor location #f) | |
369 | (define-response-accessor proxy-authenticate #f) | |
370 | (define-response-accessor retry-after #f) | |
371 | (define-response-accessor server #f) | |
372 | (define-response-accessor vary '()) | |
373 | (define-response-accessor www-authenticate #f) |