Commit | Line | Data |
---|---|---|
ad05d4e8 AW |
1 | ;;; HTTP request objects |
2 | ||
da03005a | 3 | ;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. |
ad05d4e8 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 request) | |
23 | #:use-module (rnrs bytevectors) | |
6854c324 | 24 | #:use-module (ice-9 binary-ports) |
ad05d4e8 AW |
25 | #:use-module (ice-9 rdelim) |
26 | #:use-module (srfi srfi-9) | |
27 | #:use-module (web uri) | |
28 | #:use-module (web http) | |
29 | #:export (request? | |
30 | request-method | |
31 | request-uri | |
32 | request-version | |
33 | request-headers | |
d4b6200a | 34 | request-meta |
ad05d4e8 AW |
35 | request-port |
36 | ||
37 | read-request | |
38 | build-request | |
39 | write-request | |
40 | ||
3475fbb5 AW |
41 | read-request-body |
42 | write-request-body | |
ad05d4e8 AW |
43 | |
44 | ;; General headers | |
45 | ;; | |
46 | request-cache-control | |
47 | request-connection | |
48 | request-date | |
49 | request-pragma | |
50 | request-trailer | |
51 | request-transfer-encoding | |
52 | request-upgrade | |
53 | request-via | |
54 | request-warning | |
55 | ||
56 | ;; Entity headers | |
57 | ;; | |
58 | request-allow | |
59 | request-content-encoding | |
60 | request-content-language | |
61 | request-content-length | |
62 | request-content-location | |
63 | request-content-md5 | |
64 | request-content-range | |
65 | request-content-type | |
66 | request-expires | |
67 | request-last-modified | |
68 | ||
69 | ;; Request headers | |
70 | ;; | |
71 | request-accept | |
72 | request-accept-charset | |
73 | request-accept-encoding | |
74 | request-accept-language | |
75 | request-authorization | |
76 | request-expect | |
77 | request-from | |
78 | request-host | |
79 | request-if-match | |
80 | request-if-modified-since | |
81 | request-if-none-match | |
82 | request-if-range | |
83 | request-if-unmodified-since | |
84 | request-max-forwards | |
85 | request-proxy-authorization | |
86 | request-range | |
87 | request-referer | |
88 | request-te | |
89 | request-user-agent | |
90 | ||
91 | ;; Misc | |
92 | request-absolute-uri)) | |
93 | ||
94 | ||
95 | ;;; {Character Encodings, Strings, and Bytevectors} | |
96 | ;;; | |
97 | ;;; Requests are read from over the wire, and as such have to be treated | |
98 | ;;; very carefully. | |
99 | ;;; | |
100 | ;;; The header portion of the message is defined to be in a subset of | |
101 | ;;; ASCII, and may be processed either byte-wise (using bytevectors and | |
102 | ;;; binary I/O) or as characters in a single-byte ASCII-compatible | |
103 | ;;; encoding. | |
104 | ;;; | |
105 | ;;; We choose the latter, processing as strings in the latin-1 | |
106 | ;;; encoding. This allows us to use all the read-delimited machinery, | |
107 | ;;; character sets, and regular expressions, shared substrings, etc. | |
108 | ;;; | |
109 | ;;; The characters in the header values may themselves encode other | |
110 | ;;; bytes or characters -- basically each header has its own parser. We | |
111 | ;;; leave that as a header-specific topic. | |
112 | ;;; | |
113 | ;;; The body is present if the content-length header is present. Its | |
114 | ;;; format and, if textual, encoding is determined by the headers, but | |
115 | ;;; its length is encoded in bytes. So we just slurp that number of | |
116 | ;;; characters in latin-1, knowing that the number of characters | |
117 | ;;; corresponds to the number of bytes, and then convert to a | |
118 | ;;; bytevector, perhaps for later decoding. | |
119 | ;;; | |
120 | ||
121 | (define-record-type <request> | |
d4b6200a | 122 | (make-request method uri version headers meta port) |
ad05d4e8 AW |
123 | request? |
124 | (method request-method) | |
125 | (uri request-uri) | |
126 | (version request-version) | |
127 | (headers request-headers) | |
d4b6200a | 128 | (meta request-meta) |
ad05d4e8 AW |
129 | (port request-port)) |
130 | ||
131 | (define (bad-request message . args) | |
132 | (throw 'bad-request message args)) | |
133 | ||
da03005a AW |
134 | (define (bad-request-printer port key args default-printer) |
135 | (apply (case-lambda | |
136 | ((msg args) | |
137 | (display "Bad request: " port) | |
138 | (apply format port msg args) | |
139 | (newline port)) | |
140 | (_ (default-printer))) | |
141 | args)) | |
142 | ||
143 | (set-exception-printer! 'bad-request bad-request-printer) | |
144 | ||
ad05d4e8 AW |
145 | (define (non-negative-integer? n) |
146 | (and (number? n) (>= n 0) (exact? n) (integer? n))) | |
147 | ||
148 | (define (validate-headers headers) | |
149 | (if (pair? headers) | |
150 | (let ((h (car headers))) | |
151 | (if (pair? h) | |
152 | (let ((k (car h)) (v (cdr h))) | |
be1be3e5 AW |
153 | (if (valid-header? k v) |
154 | (validate-headers (cdr headers)) | |
155 | (bad-request "Bad value for header ~a: ~s" k v))) | |
ad05d4e8 AW |
156 | (bad-request "Header not a pair: ~a" h))) |
157 | (if (not (null? headers)) | |
158 | (bad-request "Headers not a list: ~a" headers)))) | |
159 | ||
f944ee8f | 160 | (define* (build-request uri #:key (method 'GET) (version '(1 . 1)) |
d4b6200a AW |
161 | (headers '()) port (meta '()) |
162 | (validate-headers? #t)) | |
06883ae0 | 163 | "Construct an HTTP request object. If VALIDATE-HEADERS? is true, |
cc1e26c2 | 164 | the headers are each run through their respective validators." |
037a6803 AW |
165 | (let ((needs-host? (and (equal? version '(1 . 1)) |
166 | (not (assq-ref headers 'host))))) | |
167 | (cond | |
168 | ((not (and (pair? version) | |
169 | (non-negative-integer? (car version)) | |
170 | (non-negative-integer? (cdr version)))) | |
171 | (bad-request "Bad version: ~a" version)) | |
172 | ((not (uri? uri)) | |
173 | (bad-request "Bad uri: ~a" uri)) | |
174 | ((and (not port) (memq method '(POST PUT))) | |
175 | (bad-request "Missing port for message ~a" method)) | |
176 | ((not (list? meta)) | |
177 | (bad-request "Bad metadata alist" meta)) | |
178 | ((and needs-host? (not (uri-host uri))) | |
179 | (bad-request "HTTP/1.1 request without Host header and no host in URI: ~a" | |
180 | uri)) | |
181 | (else | |
182 | (if validate-headers? | |
183 | (validate-headers headers)))) | |
184 | (make-request method uri version | |
185 | (if needs-host? | |
186 | (acons 'host (cons (uri-host uri) (uri-port uri)) | |
187 | headers) | |
188 | headers) | |
189 | meta port))) | |
ad05d4e8 | 190 | |
d4b6200a | 191 | (define* (read-request port #:optional (meta '())) |
06883ae0 DH |
192 | "Read an HTTP request from PORT, optionally attaching the given |
193 | metadata, META. | |
cc1e26c2 | 194 | |
06883ae0 | 195 | As a side effect, sets the encoding on PORT to |
cc1e26c2 AW |
196 | ISO-8859-1 (latin-1), so that reading one character reads one byte. See |
197 | the discussion of character sets in \"HTTP Requests\" in the manual, for | |
06883ae0 DH |
198 | more information. |
199 | ||
200 | Note that the body is not part of the request. Once you have read a | |
201 | request, you may read the body separately, and likewise for writing | |
202 | requests." | |
ad05d4e8 AW |
203 | (set-port-encoding! port "ISO-8859-1") |
204 | (call-with-values (lambda () (read-request-line port)) | |
205 | (lambda (method uri version) | |
d4b6200a | 206 | (make-request method uri version (read-headers port) meta port)))) |
ad05d4e8 | 207 | |
d4b6200a | 208 | ;; FIXME: really return a new request? |
ad05d4e8 | 209 | (define (write-request r port) |
06883ae0 | 210 | "Write the given HTTP request to PORT. |
cc1e26c2 | 211 | |
06883ae0 DH |
212 | Return a new request, whose ‘request-port’ will continue writing |
213 | on PORT, perhaps using some transfer encoding." | |
ad05d4e8 AW |
214 | (write-request-line (request-method r) (request-uri r) |
215 | (request-version r) port) | |
216 | (write-headers (request-headers r) port) | |
217 | (display "\r\n" port) | |
218 | (if (eq? port (request-port r)) | |
219 | r | |
220 | (make-request (request-method r) (request-uri r) (request-version r) | |
d4b6200a | 221 | (request-headers r) (request-meta r) port))) |
ad05d4e8 | 222 | |
3475fbb5 | 223 | (define (read-request-body r) |
06883ae0 DH |
224 | "Reads the request body from R, as a bytevector. Return ‘#f’ |
225 | if there was no request body." | |
ad05d4e8 AW |
226 | (let ((nbytes (request-content-length r))) |
227 | (and nbytes | |
228 | (let ((bv (get-bytevector-n (request-port r) nbytes))) | |
229 | (if (= (bytevector-length bv) nbytes) | |
230 | bv | |
231 | (bad-request "EOF while reading request body: ~a bytes of ~a" | |
232 | (bytevector-length bv) nbytes)))))) | |
233 | ||
3475fbb5 | 234 | (define (write-request-body r bv) |
06883ae0 DH |
235 | "Write BV, a bytevector, to the port corresponding to the HTTP |
236 | request R." | |
ad05d4e8 AW |
237 | (put-bytevector (request-port r) bv)) |
238 | ||
239 | (define-syntax define-request-accessor | |
240 | (lambda (x) | |
241 | (syntax-case x () | |
242 | ((_ field) | |
243 | #'(define-request-accessor field #f)) | |
244 | ((_ field def) (identifier? #'field) | |
245 | #`(define* (#,(datum->syntax | |
246 | #'field | |
247 | (symbol-append 'request- (syntax->datum #'field))) | |
248 | request | |
249 | #:optional (default def)) | |
250 | (cond | |
251 | ((assq 'field (request-headers request)) => cdr) | |
252 | (else default))))))) | |
253 | ||
254 | ;; General headers | |
255 | ;; | |
256 | (define-request-accessor cache-control '()) | |
257 | (define-request-accessor connection '()) | |
258 | (define-request-accessor date #f) | |
259 | (define-request-accessor pragma '()) | |
260 | (define-request-accessor trailer '()) | |
261 | (define-request-accessor transfer-encoding '()) | |
262 | (define-request-accessor upgrade '()) | |
263 | (define-request-accessor via '()) | |
264 | (define-request-accessor warning '()) | |
265 | ||
266 | ;; Entity headers | |
267 | ;; | |
268 | (define-request-accessor allow '()) | |
269 | (define-request-accessor content-encoding '()) | |
270 | (define-request-accessor content-language '()) | |
271 | (define-request-accessor content-length #f) | |
272 | (define-request-accessor content-location #f) | |
273 | (define-request-accessor content-md5 #f) | |
274 | (define-request-accessor content-range #f) | |
275 | (define-request-accessor content-type #f) | |
276 | (define-request-accessor expires #f) | |
277 | (define-request-accessor last-modified #f) | |
278 | ||
279 | ;; Request headers | |
280 | ;; | |
281 | (define-request-accessor accept '()) | |
282 | (define-request-accessor accept-charset '()) | |
283 | (define-request-accessor accept-encoding '()) | |
284 | (define-request-accessor accept-language '()) | |
285 | (define-request-accessor authorization #f) | |
286 | (define-request-accessor expect '()) | |
287 | (define-request-accessor from #f) | |
288 | (define-request-accessor host #f) | |
289 | ;; Absence of an if-directive appears to be different from `*'. | |
290 | (define-request-accessor if-match #f) | |
291 | (define-request-accessor if-modified-since #f) | |
292 | (define-request-accessor if-none-match #f) | |
293 | (define-request-accessor if-range #f) | |
294 | (define-request-accessor if-unmodified-since #f) | |
295 | (define-request-accessor max-forwards #f) | |
296 | (define-request-accessor proxy-authorization #f) | |
297 | (define-request-accessor range #f) | |
298 | (define-request-accessor referer #f) | |
299 | (define-request-accessor te '()) | |
300 | (define-request-accessor user-agent #f) | |
301 | ||
302 | ;; Misc accessors | |
18c44b29 AW |
303 | (define* (request-absolute-uri r #:optional default-host default-port |
304 | default-scheme) | |
06883ae0 DH |
305 | "A helper routine to determine the absolute URI of a request, using the |
306 | ‘host’ header and the default host and port." | |
ad05d4e8 AW |
307 | (let ((uri (request-uri r))) |
308 | (if (uri-host uri) | |
309 | uri | |
310 | (let ((host | |
311 | (or (request-host r) | |
312 | (if default-host | |
313 | (cons default-host default-port) | |
314 | (bad-request | |
315 | "URI not absolute, no Host header, and no default: ~s" | |
316 | uri))))) | |
18c44b29 AW |
317 | (build-uri (or (uri-scheme uri) |
318 | default-scheme | |
319 | (bad-request "URI not absolute and no default-port" | |
320 | uri)) | |
ad05d4e8 AW |
321 | #:host (car host) |
322 | #:port (cdr host) | |
323 | #:path (uri-path uri) | |
324 | #:query (uri-query uri) | |
325 | #:fragment (uri-fragment uri)))))) |