Commit | Line | Data |
---|---|---|
a9eeb2f4 AW |
1 | ;;; HTTP response objects |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
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) | |
24 | #:use-module (rnrs io ports) | |
25 | #:use-module (ice-9 rdelim) | |
26 | #:use-module (srfi srfi-9) | |
27 | #:use-module (web http) | |
28 | #:export (response? | |
29 | response-version | |
30 | response-code | |
31 | response-reason-phrase | |
32 | response-headers | |
33 | response-port | |
34 | read-response | |
35 | build-response | |
3d959779 | 36 | extend-response |
c6371902 | 37 | adapt-response-version |
a9eeb2f4 AW |
38 | write-response |
39 | ||
40 | read-response-body/latin-1 | |
41 | write-response-body/latin-1 | |
42 | ||
43 | read-response-body/bytevector | |
44 | write-response-body/bytevector | |
45 | ||
46 | ;; General headers | |
47 | ;; | |
48 | response-cache-control | |
49 | response-connection | |
50 | response-date | |
51 | response-pragma | |
52 | response-trailer | |
53 | response-transfer-encoding | |
54 | response-upgrade | |
55 | response-via | |
56 | response-warning | |
57 | ||
58 | ;; Entity headers | |
59 | ;; | |
60 | response-allow | |
61 | response-content-encoding | |
62 | response-content-language | |
63 | response-content-length | |
64 | response-content-location | |
65 | response-content-md5 | |
66 | response-content-range | |
67 | response-content-type | |
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 | ||
96 | (define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase | |
97 | (headers '()) port) | |
98 | (make-response version code reason-phrase headers port)) | |
99 | ||
3d959779 AW |
100 | (define (extend-response r k v . additional) |
101 | (let ((r (build-response #:version (response-version r) | |
102 | #:code (response-code r) | |
103 | #:reason-phrase (%response-reason-phrase r) | |
104 | #:headers | |
105 | (assoc-set! (copy-tree (response-headers r)) | |
106 | k v) | |
107 | #:port (response-port r)))) | |
108 | (if (null? additional) | |
109 | r | |
110 | (apply extend-response r additional)))) | |
111 | ||
a9eeb2f4 AW |
112 | (define *reason-phrases* |
113 | '((100 . "Continue") | |
114 | (101 . "Switching Protocols") | |
115 | (200 . "OK") | |
116 | (201 . "Created") | |
117 | (202 . "Accepted") | |
118 | (203 . "Non-Authoritative Information") | |
119 | (204 . "No Content") | |
120 | (205 . "Reset Content") | |
121 | (206 . "Partial Content") | |
122 | (300 . "Multiple Choices") | |
123 | (301 . "Moved Permanently") | |
124 | (302 . "Found") | |
125 | (303 . "See Other") | |
126 | (304 . "Not Modified") | |
127 | (305 . "Use Proxy") | |
128 | (307 . "Temporary Redirect") | |
129 | (400 . "Bad Request") | |
130 | (401 . "Unauthorized") | |
131 | (402 . "Payment Required") | |
132 | (403 . "Forbidden") | |
133 | (404 . "Not Found") | |
134 | (405 . "Method Not Allowed") | |
135 | (406 . "Not Acceptable") | |
136 | (407 . "Proxy Authentication Required") | |
137 | (408 . "Request Timeout") | |
138 | (409 . "Conflict") | |
139 | (410 . "Gone") | |
140 | (411 . "Length Required") | |
141 | (412 . "Precondition Failed") | |
142 | (413 . "Request Entity Too Large") | |
143 | (414 . "Request-URI Too Long") | |
144 | (415 . "Unsupported Media Type") | |
145 | (416 . "Requested Range Not Satisfiable") | |
146 | (417 . "Expectation Failed") | |
147 | (500 . "Internal Server Error") | |
148 | (501 . "Not Implemented") | |
149 | (502 . "Bad Gateway") | |
150 | (503 . "Service Unavailable") | |
151 | (504 . "Gateway Timeout") | |
152 | (505 . "HTTP Version Not Supported"))) | |
153 | ||
154 | (define (code->reason-phrase code) | |
155 | (or (assv-ref *reason-phrases* code) | |
156 | "(Unknown)")) | |
157 | ||
158 | (define (response-reason-phrase response) | |
159 | (or (%response-reason-phrase response) | |
160 | (code->reason-phrase (response-code response)))) | |
161 | ||
162 | (define (read-response port) | |
163 | (set-port-encoding! port "ISO-8859-1") | |
164 | (call-with-values (lambda () (read-response-line port)) | |
165 | (lambda (version code reason-phrase) | |
166 | (make-response version code reason-phrase (read-headers port) port)))) | |
167 | ||
c6371902 AW |
168 | (define (adapt-response-version response version) |
169 | (build-response #:code (response-code response) | |
170 | #:version version | |
171 | #:headers (response-headers response) | |
172 | #:port (response-port response))) | |
173 | ||
a9eeb2f4 AW |
174 | (define (write-response r port) |
175 | (write-response-line (response-version r) (response-code r) | |
176 | (response-reason-phrase r) port) | |
177 | (write-headers (response-headers r) port) | |
178 | (display "\r\n" port) | |
179 | (if (eq? port (response-port r)) | |
180 | r | |
181 | (make-response (response-version r) (response-code r) | |
182 | (response-reason-phrase r) (response-headers r) port))) | |
183 | ||
184 | ;; Probably not what you want to use "in production". Relies on one byte | |
185 | ;; per char because we are in latin-1 encoding. | |
186 | ;; | |
187 | (define (read-response-body/latin-1 r) | |
e46f69e2 AW |
188 | (cond |
189 | ((response-content-length r) => | |
190 | (lambda (nbytes) | |
191 | (let ((buf (make-string nbytes)) | |
192 | (port (response-port r))) | |
193 | (let lp ((i 0)) | |
194 | (cond | |
195 | ((< i nbytes) | |
196 | (let ((c (read-char port))) | |
197 | (cond | |
198 | ((eof-object? c) | |
199 | (bad-response "EOF while reading response body: ~a bytes of ~a" | |
200 | i nbytes)) | |
201 | (else | |
202 | (string-set! buf i c) | |
203 | (lp (1+ i)))))) | |
204 | (else buf)))))) | |
205 | (else #f))) | |
a9eeb2f4 AW |
206 | |
207 | ;; Likewise, assumes that body can be written in the latin-1 encoding, | |
208 | ;; and that the latin-1 encoding is what is expected by the server. | |
209 | ;; | |
210 | (define (write-response-body/latin-1 r body) | |
211 | (display body (response-port r))) | |
212 | ||
213 | (define (read-response-body/bytevector r) | |
214 | (let ((nbytes (response-content-length r))) | |
215 | (and nbytes | |
216 | (let ((bv (get-bytevector-n (response-port r) nbytes))) | |
217 | (if (= (bytevector-length bv) nbytes) | |
218 | bv | |
219 | (bad-response "EOF while reading response body: ~a bytes of ~a" | |
220 | (bytevector-length bv) nbytes)))))) | |
221 | ||
222 | (define (write-response-body/bytevector r bv) | |
223 | (put-bytevector (response-port r) bv)) | |
224 | ||
225 | (define-syntax define-response-accessor | |
226 | (lambda (x) | |
227 | (syntax-case x () | |
228 | ((_ field) | |
229 | #'(define-response-accessor field #f)) | |
230 | ((_ field def) (identifier? #'field) | |
231 | #`(define* (#,(datum->syntax | |
232 | #'field | |
233 | (symbol-append 'response- (syntax->datum #'field))) | |
234 | response | |
235 | #:optional (default def)) | |
236 | (cond | |
237 | ((assq 'field (response-headers response)) => cdr) | |
238 | (else default))))))) | |
239 | ||
240 | ;; General headers | |
241 | ;; | |
242 | (define-response-accessor cache-control '()) | |
243 | (define-response-accessor connection '()) | |
244 | (define-response-accessor date #f) | |
245 | (define-response-accessor pragma '()) | |
246 | (define-response-accessor trailer '()) | |
247 | (define-response-accessor transfer-encoding '()) | |
248 | (define-response-accessor upgrade '()) | |
249 | (define-response-accessor via '()) | |
250 | (define-response-accessor warning '()) | |
251 | ||
252 | ;; Entity headers | |
253 | ;; | |
254 | (define-response-accessor allow '()) | |
255 | (define-response-accessor content-encoding '()) | |
256 | (define-response-accessor content-language '()) | |
257 | (define-response-accessor content-length #f) | |
258 | (define-response-accessor content-location #f) | |
259 | (define-response-accessor content-md5 #f) | |
260 | (define-response-accessor content-range #f) | |
261 | (define-response-accessor content-type #f) | |
262 | (define-response-accessor expires #f) | |
263 | (define-response-accessor last-modified #f) | |
264 | ||
265 | ;; Response headers | |
266 | ;; | |
267 | (define-response-accessor accept-ranges #f) | |
268 | (define-response-accessor age #f) | |
269 | (define-response-accessor etag #f) | |
270 | (define-response-accessor location #f) | |
271 | (define-response-accessor proxy-authenticate #f) | |
272 | (define-response-accessor retry-after #f) | |
273 | (define-response-accessor server #f) | |
274 | (define-response-accessor vary '()) | |
275 | (define-response-accessor www-authenticate #f) |