Commit | Line | Data |
---|---|---|
440840c1 AW |
1 | ;;; HTTP messages |
2 | ||
89d45e85 | 3 | ;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. |
440840c1 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 | ||
9eed1010 AW |
20 | ;;; Commentary: |
21 | ;;; | |
22 | ;;; This module has a number of routines to parse textual | |
23 | ;;; representations of HTTP data into native Scheme data structures. | |
24 | ;;; | |
25 | ;;; It tries to follow RFCs fairly strictly---the road to perdition | |
26 | ;;; being paved with compatibility hacks---though some allowances are | |
27 | ;;; made for not-too-divergent texts (like a quality of .2 which should | |
28 | ;;; be 0.2, etc). | |
29 | ;;; | |
440840c1 AW |
30 | ;;; Code: |
31 | ||
32 | (define-module (web http) | |
33 | #:use-module ((srfi srfi-1) #:select (append-map! map!)) | |
34 | #:use-module (srfi srfi-9) | |
35 | #:use-module (srfi srfi-19) | |
440840c1 | 36 | #:use-module (ice-9 rdelim) |
312e79f8 IP |
37 | #:use-module (ice-9 q) |
38 | #:use-module (ice-9 binary-ports) | |
39 | #:use-module (rnrs bytevectors) | |
440840c1 | 40 | #:use-module (web uri) |
7118eccd AW |
41 | #:export (string->header |
42 | header->string | |
43 | ||
440840c1 | 44 | declare-header! |
64ead01d | 45 | declare-opaque-header! |
7118eccd AW |
46 | known-header? |
47 | header-parser | |
48 | header-validator | |
49 | header-writer | |
440840c1 AW |
50 | |
51 | read-header | |
52 | parse-header | |
53 | valid-header? | |
54 | write-header | |
55 | ||
56 | read-headers | |
57 | write-headers | |
58 | ||
13b7e2a6 AW |
59 | parse-http-method |
60 | parse-http-version | |
61 | parse-request-uri | |
62 | ||
440840c1 AW |
63 | read-request-line |
64 | write-request-line | |
65 | read-response-line | |
312e79f8 IP |
66 | write-response-line |
67 | ||
68 | make-chunked-input-port | |
69 | make-chunked-output-port)) | |
440840c1 AW |
70 | |
71 | ||
72 | ;;; TODO | |
73 | ;;; | |
74 | ;;; Look at quality lists with more insight. | |
75 | ;;; Think about `accept' a bit more. | |
76 | ;;; | |
77 | ||
78 | ||
7118eccd | 79 | (define (string->header name) |
06883ae0 | 80 | "Parse NAME to a symbolic header name." |
7118eccd AW |
81 | (string->symbol (string-downcase name))) |
82 | ||
440840c1 | 83 | (define-record-type <header-decl> |
7118eccd | 84 | (make-header-decl name parser validator writer multiple?) |
440840c1 | 85 | header-decl? |
440840c1 | 86 | (name header-decl-name) |
440840c1 AW |
87 | (parser header-decl-parser) |
88 | (validator header-decl-validator) | |
7118eccd AW |
89 | (writer header-decl-writer) |
90 | (multiple? header-decl-multiple?)) | |
440840c1 AW |
91 | |
92 | ;; sym -> header | |
93 | (define *declared-headers* (make-hash-table)) | |
440840c1 | 94 | |
7118eccd AW |
95 | (define (lookup-header-decl sym) |
96 | (hashq-ref *declared-headers* sym)) | |
97 | ||
be1be3e5 | 98 | (define* (declare-header! name |
440840c1 AW |
99 | parser |
100 | validator | |
be1be3e5 AW |
101 | writer |
102 | #:key multiple?) | |
06883ae0 | 103 | "Declare a parser, validator, and writer for a given header." |
be1be3e5 | 104 | (if (and (string? name) parser validator writer) |
7118eccd AW |
105 | (let ((decl (make-header-decl name parser validator writer multiple?))) |
106 | (hashq-set! *declared-headers* (string->header name) decl) | |
440840c1 | 107 | decl) |
7118eccd AW |
108 | (error "bad header decl" name parser validator writer multiple?))) |
109 | ||
110 | (define (header->string sym) | |
06883ae0 | 111 | "Return the string form for the header named SYM." |
7118eccd AW |
112 | (let ((decl (lookup-header-decl sym))) |
113 | (if decl | |
114 | (header-decl-name decl) | |
115 | (string-titlecase (symbol->string sym))))) | |
116 | ||
117 | (define (known-header? sym) | |
06883ae0 DH |
118 | "Return ‘#t’ iff SYM is a known header, with associated |
119 | parsers and serialization procedures." | |
7118eccd AW |
120 | (and (lookup-header-decl sym) #t)) |
121 | ||
122 | (define (header-parser sym) | |
06883ae0 DH |
123 | "Return the value parser for headers named SYM. The result is a |
124 | procedure that takes one argument, a string, and returns the parsed | |
125 | value. If the header isn't known to Guile, a default parser is returned | |
126 | that passes through the string unchanged." | |
7118eccd AW |
127 | (let ((decl (lookup-header-decl sym))) |
128 | (if decl | |
129 | (header-decl-parser decl) | |
130 | (lambda (x) x)))) | |
131 | ||
132 | (define (header-validator sym) | |
06883ae0 DH |
133 | "Return a predicate which returns ‘#t’ if the given value is valid |
134 | for headers named SYM. The default validator for unknown headers | |
135 | is ‘string?’." | |
7118eccd AW |
136 | (let ((decl (lookup-header-decl sym))) |
137 | (if decl | |
138 | (header-decl-validator decl) | |
139 | string?))) | |
140 | ||
141 | (define (header-writer sym) | |
06883ae0 DH |
142 | "Return a procedure that writes values for headers named SYM to a |
143 | port. The resulting procedure takes two arguments: a value and a port. | |
144 | The default writer is ‘display’." | |
7118eccd AW |
145 | (let ((decl (lookup-header-decl sym))) |
146 | (if decl | |
147 | (header-decl-writer decl) | |
148 | display))) | |
440840c1 AW |
149 | |
150 | (define (read-line* port) | |
151 | (let* ((pair (%read-line port)) | |
152 | (line (car pair)) | |
153 | (delim (cdr pair))) | |
154 | (if (and (string? line) (char? delim)) | |
155 | (let ((orig-len (string-length line))) | |
156 | (let lp ((len orig-len)) | |
157 | (if (and (> len 0) | |
158 | (char-whitespace? (string-ref line (1- len)))) | |
159 | (lp (1- len)) | |
160 | (if (= len orig-len) | |
161 | line | |
162 | (substring line 0 len))))) | |
163 | (bad-header '%read line)))) | |
164 | ||
165 | (define (read-continuation-line port val) | |
166 | (if (or (eqv? (peek-char port) #\space) | |
167 | (eqv? (peek-char port) #\tab)) | |
168 | (read-continuation-line port | |
169 | (string-append val | |
170 | (begin | |
171 | (read-line* port)))) | |
172 | val)) | |
173 | ||
929ccf48 AW |
174 | (define *eof* (call-with-input-string "" read)) |
175 | ||
440840c1 | 176 | (define (read-header port) |
06883ae0 | 177 | "Reads one HTTP header from PORT. Returns two values: the header |
92c5c0b6 AW |
178 | name and the parsed Scheme value. May raise an exception if the header |
179 | was known but the value was invalid. | |
180 | ||
929ccf48 AW |
181 | Returns the end-of-file object for both values if the end of the message |
182 | body was reached (i.e., a blank line)." | |
440840c1 AW |
183 | (let ((line (read-line* port))) |
184 | (if (or (string-null? line) | |
185 | (string=? line "\r")) | |
929ccf48 | 186 | (values *eof* *eof*) |
be1be3e5 AW |
187 | (let* ((delim (or (string-index line #\:) |
188 | (bad-header '%read line))) | |
7118eccd | 189 | (sym (string->header (substring line 0 delim)))) |
be1be3e5 AW |
190 | (values |
191 | sym | |
192 | (parse-header | |
193 | sym | |
194 | (read-continuation-line | |
195 | port | |
47153f29 | 196 | (string-trim-both line char-set:whitespace (1+ delim))))))))) |
be1be3e5 | 197 | |
be1be3e5 | 198 | (define (parse-header sym val) |
06883ae0 DH |
199 | "Parse VAL, a string, with the parser registered for the header |
200 | named SYM. Returns the parsed value." | |
7118eccd | 201 | ((header-parser sym) val)) |
440840c1 AW |
202 | |
203 | (define (valid-header? sym val) | |
06883ae0 DH |
204 | "Returns a true value iff VAL is a valid Scheme value for the |
205 | header with name SYM." | |
be1be3e5 | 206 | (if (symbol? sym) |
7118eccd | 207 | ((header-validator sym) val) |
be1be3e5 AW |
208 | (error "header name not a symbol" sym))) |
209 | ||
210 | (define (write-header sym val port) | |
06883ae0 DH |
211 | "Write the given header name and value to PORT, using the writer |
212 | from ‘header-writer’." | |
7118eccd AW |
213 | (display (header->string sym) port) |
214 | (display ": " port) | |
215 | ((header-writer sym) val port) | |
216 | (display "\r\n" port)) | |
440840c1 AW |
217 | |
218 | (define (read-headers port) | |
06883ae0 DH |
219 | "Read the headers of an HTTP message from PORT, returning them |
220 | as an ordered alist." | |
440840c1 AW |
221 | (let lp ((headers '())) |
222 | (call-with-values (lambda () (read-header port)) | |
223 | (lambda (k v) | |
929ccf48 AW |
224 | (if (eof-object? k) |
225 | (reverse! headers) | |
226 | (lp (acons k v headers))))))) | |
440840c1 | 227 | |
440840c1 | 228 | (define (write-headers headers port) |
06883ae0 DH |
229 | "Write the given header alist to PORT. Doesn't write the final |
230 | @samp{\\r\\n}, as the user might want to add another header." | |
440840c1 AW |
231 | (let lp ((headers headers)) |
232 | (if (pair? headers) | |
233 | (begin | |
234 | (write-header (caar headers) (cdar headers) port) | |
235 | (lp (cdr headers)))))) | |
236 | ||
237 | ||
238 | \f | |
239 | ||
240 | ;;; | |
241 | ;;; Utilities | |
242 | ;;; | |
243 | ||
244 | (define (bad-header sym val) | |
245 | (throw 'bad-header sym val)) | |
246 | (define (bad-header-component sym val) | |
1be6c7d3 AW |
247 | (throw 'bad-header-component sym val)) |
248 | ||
249 | (define (bad-header-printer port key args default-printer) | |
250 | (apply (case-lambda | |
251 | ((sym val) | |
252 | (format port "Bad ~a header: ~a\n" (header->string sym) val)) | |
253 | (_ (default-printer))) | |
254 | args)) | |
255 | (define (bad-header-component-printer port key args default-printer) | |
256 | (apply (case-lambda | |
257 | ((sym val) | |
258 | (format port "Bad ~a header component: ~a\n" sym val)) | |
259 | (_ (default-printer))) | |
260 | args)) | |
261 | (set-exception-printer! 'bad-header bad-header-printer) | |
262 | (set-exception-printer! 'bad-header-component bad-header-component-printer) | |
440840c1 AW |
263 | |
264 | (define (parse-opaque-string str) | |
265 | str) | |
266 | (define (validate-opaque-string val) | |
267 | (string? val)) | |
268 | (define (write-opaque-string val port) | |
269 | (display val port)) | |
270 | ||
7aa54882 AW |
271 | (define separators-without-slash |
272 | (string->char-set "[^][()<>@,;:\\\"?= \t]")) | |
273 | (define (validate-media-type str) | |
274 | (let ((idx (string-index str #\/))) | |
275 | (and idx (= idx (string-rindex str #\/)) | |
276 | (not (string-index str separators-without-slash))))) | |
440840c1 | 277 | (define (parse-media-type str) |
7aa54882 | 278 | (if (validate-media-type str) |
0acc595b | 279 | (string->symbol str) |
7aa54882 | 280 | (bad-header-component 'media-type str))) |
440840c1 AW |
281 | |
282 | (define* (skip-whitespace str #:optional (start 0) (end (string-length str))) | |
283 | (let lp ((i start)) | |
284 | (if (and (< i end) (char-whitespace? (string-ref str i))) | |
285 | (lp (1+ i)) | |
286 | i))) | |
287 | ||
288 | (define* (trim-whitespace str #:optional (start 0) (end (string-length str))) | |
289 | (let lp ((i end)) | |
290 | (if (and (< start i) (char-whitespace? (string-ref str (1- i)))) | |
291 | (lp (1- i)) | |
292 | i))) | |
293 | ||
294 | (define* (split-and-trim str #:optional (delim #\,) | |
295 | (start 0) (end (string-length str))) | |
296 | (let lp ((i start)) | |
297 | (if (< i end) | |
298 | (let* ((idx (string-index str delim i end)) | |
47153f29 | 299 | (tok (string-trim-both str char-set:whitespace i (or idx end)))) |
440840c1 AW |
300 | (cons tok (split-and-trim str delim (if idx (1+ idx) end) end))) |
301 | '()))) | |
302 | ||
adc91e41 AW |
303 | (define (list-of-strings? val) |
304 | (list-of? val string?)) | |
305 | ||
306 | (define (write-list-of-strings val port) | |
307 | (write-list val port display ", ")) | |
308 | ||
309 | (define (split-header-names str) | |
7118eccd | 310 | (map string->header (split-and-trim str))) |
adc91e41 AW |
311 | |
312 | (define (list-of-header-names? val) | |
be1be3e5 | 313 | (list-of? val symbol?)) |
adc91e41 AW |
314 | |
315 | (define (write-header-list val port) | |
316 | (write-list val port | |
317 | (lambda (x port) | |
7118eccd | 318 | (display (header->string x) port)) |
adc91e41 AW |
319 | ", ")) |
320 | ||
440840c1 AW |
321 | (define (collect-escaped-string from start len escapes) |
322 | (let ((to (make-string len))) | |
323 | (let lp ((start start) (i 0) (escapes escapes)) | |
324 | (if (null? escapes) | |
325 | (begin | |
326 | (substring-move! from start (+ start (- len i)) to i) | |
327 | to) | |
328 | (let* ((e (car escapes)) | |
329 | (next-start (+ start (- e i) 2))) | |
330 | (substring-move! from start (- next-start 2) to i) | |
331 | (string-set! to e (string-ref from (- next-start 1))) | |
332 | (lp next-start (1+ e) (cdr escapes))))))) | |
333 | ||
334 | ;; in incremental mode, returns two values: the string, and the index at | |
335 | ;; which the string ended | |
336 | (define* (parse-qstring str #:optional | |
337 | (start 0) (end (trim-whitespace str start)) | |
338 | #:key incremental?) | |
339 | (if (and (< start end) (eqv? (string-ref str start) #\")) | |
340 | (let lp ((i (1+ start)) (qi 0) (escapes '())) | |
341 | (if (< i end) | |
342 | (case (string-ref str i) | |
343 | ((#\\) | |
344 | (lp (+ i 2) (1+ qi) (cons qi escapes))) | |
345 | ((#\") | |
346 | (let ((out (collect-escaped-string str (1+ start) qi escapes))) | |
347 | (if incremental? | |
348 | (values out (1+ i)) | |
349 | (if (= (1+ i) end) | |
350 | out | |
351 | (bad-header-component 'qstring str))))) | |
352 | (else | |
353 | (lp (1+ i) (1+ qi) escapes))) | |
354 | (bad-header-component 'qstring str))) | |
355 | (bad-header-component 'qstring str))) | |
356 | ||
357 | (define (write-list l port write-item delim) | |
358 | (if (pair? l) | |
359 | (let lp ((l l)) | |
360 | (write-item (car l) port) | |
361 | (if (pair? (cdr l)) | |
362 | (begin | |
363 | (display delim port) | |
364 | (lp (cdr l))))))) | |
365 | ||
366 | (define (write-qstring str port) | |
367 | (display #\" port) | |
368 | (if (string-index str #\") | |
369 | ;; optimize me | |
370 | (write-list (string-split str #\") port display "\\\"") | |
371 | (display str port)) | |
372 | (display #\" port)) | |
373 | ||
374 | (define* (parse-quality str #:optional (start 0) (end (string-length str))) | |
375 | (define (char->decimal c) | |
376 | (let ((i (- (char->integer c) (char->integer #\0)))) | |
377 | (if (and (<= 0 i) (< i 10)) | |
378 | i | |
379 | (bad-header-component 'quality str)))) | |
380 | (cond | |
381 | ((not (< start end)) | |
382 | (bad-header-component 'quality str)) | |
383 | ((eqv? (string-ref str start) #\1) | |
384 | (if (or (string= str "1" start end) | |
385 | (string= str "1." start end) | |
386 | (string= str "1.0" start end) | |
387 | (string= str "1.00" start end) | |
388 | (string= str "1.000" start end)) | |
389 | 1000 | |
390 | (bad-header-component 'quality str))) | |
391 | ((eqv? (string-ref str start) #\0) | |
392 | (if (or (string= str "0" start end) | |
393 | (string= str "0." start end)) | |
394 | 0 | |
395 | (if (< 2 (- end start) 6) | |
396 | (let lp ((place 1) (i (+ start 4)) (q 0)) | |
397 | (if (= i (1+ start)) | |
398 | (if (eqv? (string-ref str (1+ start)) #\.) | |
399 | q | |
400 | (bad-header-component 'quality str)) | |
401 | (lp (* 10 place) (1- i) | |
402 | (if (< i end) | |
403 | (+ q (* place (char->decimal (string-ref str i)))) | |
404 | q)))) | |
405 | (bad-header-component 'quality str)))) | |
9eed1010 AW |
406 | ;; Allow the nonstandard .2 instead of 0.2. |
407 | ((and (eqv? (string-ref str start) #\.) | |
408 | (< 1 (- end start) 5)) | |
409 | (let lp ((place 1) (i (+ start 3)) (q 0)) | |
410 | (if (= i start) | |
411 | q | |
412 | (lp (* 10 place) (1- i) | |
413 | (if (< i end) | |
414 | (+ q (* place (char->decimal (string-ref str i)))) | |
415 | q))))) | |
440840c1 AW |
416 | (else |
417 | (bad-header-component 'quality str)))) | |
418 | ||
419 | (define (valid-quality? q) | |
612aa5be | 420 | (and (non-negative-integer? q) (<= q 1000))) |
440840c1 AW |
421 | |
422 | (define (write-quality q port) | |
423 | (define (digit->char d) | |
424 | (integer->char (+ (char->integer #\0) d))) | |
425 | (display (digit->char (modulo (quotient q 1000) 10)) port) | |
426 | (display #\. port) | |
427 | (display (digit->char (modulo (quotient q 100) 10)) port) | |
428 | (display (digit->char (modulo (quotient q 10) 10)) port) | |
429 | (display (digit->char (modulo q 10)) port)) | |
430 | ||
431 | (define (list-of? val pred) | |
432 | (or (null? val) | |
433 | (and (pair? val) | |
434 | (pred (car val)) | |
435 | (list-of? (cdr val) pred)))) | |
436 | ||
437 | (define* (parse-quality-list str) | |
438 | (map (lambda (part) | |
439 | (cond | |
440 | ((string-rindex part #\;) | |
441 | => (lambda (idx) | |
47153f29 | 442 | (let ((qpart (string-trim-both part char-set:whitespace (1+ idx)))) |
440840c1 AW |
443 | (if (string-prefix? "q=" qpart) |
444 | (cons (parse-quality qpart 2) | |
47153f29 | 445 | (string-trim-both part char-set:whitespace 0 idx)) |
440840c1 AW |
446 | (bad-header-component 'quality qpart))))) |
447 | (else | |
47153f29 | 448 | (cons 1000 (string-trim-both part char-set:whitespace))))) |
440840c1 AW |
449 | (string-split str #\,))) |
450 | ||
451 | (define (validate-quality-list l) | |
452 | (list-of? l | |
453 | (lambda (elt) | |
454 | (and (pair? elt) | |
455 | (valid-quality? (car elt)) | |
456 | (string? (cdr elt)))))) | |
457 | ||
458 | (define (write-quality-list l port) | |
459 | (write-list l port | |
460 | (lambda (x port) | |
461 | (let ((q (car x)) | |
462 | (str (cdr x))) | |
463 | (display str port) | |
464 | (if (< q 1000) | |
465 | (begin | |
466 | (display ";q=" port) | |
467 | (write-quality q port))))) | |
468 | ",")) | |
469 | ||
470 | (define* (parse-non-negative-integer val #:optional (start 0) | |
471 | (end (string-length val))) | |
472 | (define (char->decimal c) | |
473 | (let ((i (- (char->integer c) (char->integer #\0)))) | |
474 | (if (and (<= 0 i) (< i 10)) | |
475 | i | |
476 | (bad-header-component 'non-negative-integer val)))) | |
477 | (if (not (< start end)) | |
478 | (bad-header-component 'non-negative-integer val) | |
479 | (let lp ((i start) (out 0)) | |
480 | (if (< i end) | |
481 | (lp (1+ i) | |
482 | (+ (* out 10) (char->decimal (string-ref val i)))) | |
483 | out)))) | |
484 | ||
485 | (define (non-negative-integer? code) | |
486 | (and (number? code) (>= code 0) (exact? code) (integer? code))) | |
487 | ||
0acc595b AW |
488 | (define (default-val-parser k val) |
489 | val) | |
440840c1 | 490 | |
0acc595b | 491 | (define (default-val-validator k val) |
69b8c5df | 492 | (or (not val) (string? val))) |
440840c1 AW |
493 | |
494 | (define (default-val-writer k val port) | |
495 | (if (or (string-index val #\;) | |
496 | (string-index val #\,) | |
497 | (string-index val #\")) | |
498 | (write-qstring val port) | |
499 | (display val port))) | |
500 | ||
0acc595b AW |
501 | (define* (parse-key-value-list str #:optional |
502 | (val-parser default-val-parser) | |
440840c1 AW |
503 | (start 0) (end (string-length str))) |
504 | (let lp ((i start) (out '())) | |
505 | (if (not (< i end)) | |
506 | (reverse! out) | |
507 | (let* ((i (skip-whitespace str i end)) | |
508 | (eq (string-index str #\= i end)) | |
509 | (comma (string-index str #\, i end)) | |
510 | (delim (min (or eq end) (or comma end))) | |
0acc595b AW |
511 | (k (string->symbol |
512 | (substring str i (trim-whitespace str i delim))))) | |
440840c1 AW |
513 | (call-with-values |
514 | (lambda () | |
515 | (if (and eq (or (not comma) (< eq comma))) | |
516 | (let ((i (skip-whitespace str (1+ eq) end))) | |
517 | (if (and (< i end) (eqv? (string-ref str i) #\")) | |
518 | (parse-qstring str i end #:incremental? #t) | |
519 | (values (substring str i | |
520 | (trim-whitespace str i | |
521 | (or comma end))) | |
522 | (or comma end)))) | |
523 | (values #f delim))) | |
524 | (lambda (v-str next-i) | |
0acc595b AW |
525 | (let ((v (val-parser k v-str)) |
526 | (i (skip-whitespace str next-i end))) | |
440840c1 | 527 | (if (or (= i end) (eqv? (string-ref str i) #\,)) |
0acc595b | 528 | (lp (1+ i) (cons (if v (cons k v) k) out)) |
440840c1 AW |
529 | (bad-header-component 'key-value-list |
530 | (substring str start end)))))))))) | |
531 | ||
532 | (define* (key-value-list? list #:optional | |
0acc595b | 533 | (valid? default-val-validator)) |
440840c1 AW |
534 | (list-of? list |
535 | (lambda (elt) | |
536 | (cond | |
537 | ((pair? elt) | |
538 | (let ((k (car elt)) | |
539 | (v (cdr elt))) | |
69b8c5df | 540 | (and (symbol? k) |
440840c1 | 541 | (valid? k v)))) |
69b8c5df | 542 | ((symbol? elt) |
440840c1 AW |
543 | (valid? elt #f)) |
544 | (else #f))))) | |
545 | ||
546 | (define* (write-key-value-list list port #:optional | |
547 | (val-writer default-val-writer) (delim ", ")) | |
548 | (write-list | |
549 | list port | |
550 | (lambda (x port) | |
551 | (let ((k (if (pair? x) (car x) x)) | |
552 | (v (if (pair? x) (cdr x) #f))) | |
553 | (display k port) | |
554 | (if v | |
555 | (begin | |
556 | (display #\= port) | |
557 | (val-writer k v port))))) | |
558 | delim)) | |
559 | ||
560 | ;; param-component = token [ "=" (token | quoted-string) ] \ | |
561 | ;; *(";" token [ "=" (token | quoted-string) ]) | |
562 | ;; | |
47153f29 AW |
563 | (define param-delimiters (char-set #\, #\; #\=)) |
564 | (define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;)) | |
0acc595b AW |
565 | (define* (parse-param-component str #:optional |
566 | (val-parser default-val-parser) | |
440840c1 AW |
567 | (start 0) (end (string-length str))) |
568 | (let lp ((i start) (out '())) | |
569 | (if (not (< i end)) | |
570 | (values (reverse! out) end) | |
47153f29 | 571 | (let ((delim (string-index str param-delimiters i))) |
0acc595b | 572 | (let ((k (string->symbol |
440840c1 AW |
573 | (substring str i (trim-whitespace str i (or delim end))))) |
574 | (delimc (and delim (string-ref str delim)))) | |
575 | (case delimc | |
576 | ((#\=) | |
577 | (call-with-values | |
578 | (lambda () | |
579 | (let ((i (skip-whitespace str (1+ delim) end))) | |
580 | (if (and (< i end) (eqv? (string-ref str i) #\")) | |
581 | (parse-qstring str i end #:incremental? #t) | |
582 | (let ((delim | |
47153f29 AW |
583 | (or (string-index str param-value-delimiters |
584 | i end) | |
440840c1 AW |
585 | end))) |
586 | (values (substring str i delim) | |
587 | delim))))) | |
588 | (lambda (v-str next-i) | |
0acc595b AW |
589 | (let* ((v (val-parser k v-str)) |
590 | (x (if v (cons k v) k)) | |
591 | (i (skip-whitespace str next-i end))) | |
440840c1 AW |
592 | (case (and (< i end) (string-ref str i)) |
593 | ((#f) | |
594 | (values (reverse! (cons x out)) end)) | |
595 | ((#\;) | |
596 | (lp (skip-whitespace str (1+ i) end) | |
597 | (cons x out))) | |
598 | (else ; including #\, | |
599 | (values (reverse! (cons x out)) i))))))) | |
600 | ((#\;) | |
0acc595b AW |
601 | (let ((v (val-parser k #f))) |
602 | (lp (skip-whitespace str (1+ delim) end) | |
603 | (cons (if v (cons k v) k) out)))) | |
440840c1 AW |
604 | |
605 | (else ;; either the end of the string or a #\, | |
0acc595b AW |
606 | (let ((v (val-parser k #f))) |
607 | (values (reverse! (cons (if v (cons k v) k) out)) | |
608 | (or delim end)))))))))) | |
440840c1 AW |
609 | |
610 | (define* (parse-param-list str #:optional | |
0acc595b | 611 | (val-parser default-val-parser) |
440840c1 AW |
612 | (start 0) (end (string-length str))) |
613 | (let lp ((i start) (out '())) | |
614 | (call-with-values | |
0acc595b | 615 | (lambda () (parse-param-component str val-parser i end)) |
440840c1 AW |
616 | (lambda (item i) |
617 | (if (< i end) | |
618 | (if (eqv? (string-ref str i) #\,) | |
619 | (lp (skip-whitespace str (1+ i) end) | |
620 | (cons item out)) | |
621 | (bad-header-component 'param-list str)) | |
622 | (reverse! (cons item out))))))) | |
623 | ||
624 | (define* (validate-param-list list #:optional | |
0acc595b | 625 | (valid? default-val-validator)) |
440840c1 AW |
626 | (list-of? list |
627 | (lambda (elt) | |
69b8c5df | 628 | (key-value-list? elt valid?)))) |
440840c1 AW |
629 | |
630 | (define* (write-param-list list port #:optional | |
631 | (val-writer default-val-writer)) | |
632 | (write-list | |
633 | list port | |
634 | (lambda (item port) | |
635 | (write-key-value-list item port val-writer ";")) | |
636 | ",")) | |
637 | ||
2b582a28 AW |
638 | (define-syntax string-match? |
639 | (lambda (x) | |
640 | (syntax-case x () | |
641 | ((_ str pat) (string? (syntax->datum #'pat)) | |
642 | (let ((p (syntax->datum #'pat))) | |
643 | #`(let ((s str)) | |
644 | (and | |
645 | (= (string-length s) #,(string-length p)) | |
646 | #,@(let lp ((i 0) (tests '())) | |
647 | (if (< i (string-length p)) | |
648 | (let ((c (string-ref p i))) | |
649 | (lp (1+ i) | |
650 | (case c | |
651 | ((#\.) ; Whatever. | |
652 | tests) | |
653 | ((#\d) ; Digit. | |
654 | (cons #`(char-numeric? (string-ref s #,i)) | |
655 | tests)) | |
656 | ((#\a) ; Alphabetic. | |
657 | (cons #`(char-alphabetic? (string-ref s #,i)) | |
658 | tests)) | |
659 | (else ; Literal. | |
660 | (cons #`(eqv? (string-ref s #,i) #,c) | |
661 | tests))))) | |
662 | tests))))))))) | |
663 | ||
664 | ;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun" | |
665 | ;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec" | |
666 | ||
667 | (define (parse-month str start end) | |
668 | (define (bad) | |
669 | (bad-header-component 'month (substring str start end))) | |
670 | (if (not (= (- end start) 3)) | |
671 | (bad) | |
672 | (let ((a (string-ref str (+ start 0))) | |
673 | (b (string-ref str (+ start 1))) | |
674 | (c (string-ref str (+ start 2)))) | |
675 | (case a | |
676 | ((#\J) | |
677 | (case b | |
678 | ((#\a) (case c ((#\n) 1) (else (bad)))) | |
679 | ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad)))) | |
680 | (else (bad)))) | |
681 | ((#\F) | |
682 | (case b | |
683 | ((#\e) (case c ((#\b) 2) (else (bad)))) | |
684 | (else (bad)))) | |
685 | ((#\M) | |
686 | (case b | |
687 | ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad)))) | |
688 | (else (bad)))) | |
689 | ((#\A) | |
690 | (case b | |
691 | ((#\p) (case c ((#\r) 4) (else (bad)))) | |
692 | ((#\u) (case c ((#\g) 8) (else (bad)))) | |
693 | (else (bad)))) | |
694 | ((#\S) | |
695 | (case b | |
696 | ((#\e) (case c ((#\p) 9) (else (bad)))) | |
697 | (else (bad)))) | |
698 | ((#\O) | |
699 | (case b | |
700 | ((#\c) (case c ((#\t) 10) (else (bad)))) | |
701 | (else (bad)))) | |
702 | ((#\N) | |
703 | (case b | |
704 | ((#\o) (case c ((#\v) 11) (else (bad)))) | |
705 | (else (bad)))) | |
706 | ((#\D) | |
707 | (case b | |
708 | ((#\e) (case c ((#\c) 12) (else (bad)))) | |
709 | (else (bad)))) | |
710 | (else (bad)))))) | |
711 | ||
712 | ;; RFC 822, updated by RFC 1123 | |
713 | ;; | |
714 | ;; Sun, 06 Nov 1994 08:49:37 GMT | |
715 | ;; 01234567890123456789012345678 | |
716 | ;; 0 1 2 | |
717 | (define (parse-rfc-822-date str) | |
718 | ;; We could verify the day of the week but we don't. | |
cb7bcfca IP |
719 | (cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT") |
720 | (let ((date (parse-non-negative-integer str 5 7)) | |
721 | (month (parse-month str 8 11)) | |
722 | (year (parse-non-negative-integer str 12 16)) | |
723 | (hour (parse-non-negative-integer str 17 19)) | |
724 | (minute (parse-non-negative-integer str 20 22)) | |
725 | (second (parse-non-negative-integer str 23 25))) | |
726 | (make-date 0 second minute hour date month year 0))) | |
727 | ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT") | |
728 | (let ((date (parse-non-negative-integer str 5 6)) | |
729 | (month (parse-month str 7 10)) | |
730 | (year (parse-non-negative-integer str 11 15)) | |
731 | (hour (parse-non-negative-integer str 16 18)) | |
732 | (minute (parse-non-negative-integer str 19 21)) | |
733 | (second (parse-non-negative-integer str 22 24))) | |
734 | (make-date 0 second minute hour date month year 0))) | |
735 | (else | |
736 | (bad-header 'date str) ; prevent tail call | |
737 | #f))) | |
2b582a28 AW |
738 | |
739 | ;; RFC 850, updated by RFC 1036 | |
740 | ;; Sunday, 06-Nov-94 08:49:37 GMT | |
741 | ;; 0123456789012345678901 | |
742 | ;; 0 1 2 | |
743 | (define (parse-rfc-850-date str comma) | |
744 | ;; We could verify the day of the week but we don't. | |
745 | (let ((tail (substring str (1+ comma)))) | |
746 | (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT")) | |
747 | (bad-header 'date str)) | |
748 | (let ((date (parse-non-negative-integer tail 1 3)) | |
749 | (month (parse-month tail 4 7)) | |
750 | (year (parse-non-negative-integer tail 8 10)) | |
751 | (hour (parse-non-negative-integer tail 11 13)) | |
752 | (minute (parse-non-negative-integer tail 14 16)) | |
753 | (second (parse-non-negative-integer tail 17 19))) | |
754 | (make-date 0 second minute hour date month | |
755 | (let* ((now (date-year (current-date))) | |
756 | (then (+ now year (- (modulo now 100))))) | |
757 | (cond ((< (+ then 50) now) (+ then 100)) | |
758 | ((< (+ now 50) then) (- then 100)) | |
759 | (else then))) | |
760 | 0)))) | |
761 | ||
762 | ;; ANSI C's asctime() format | |
763 | ;; Sun Nov 6 08:49:37 1994 | |
764 | ;; 012345678901234567890123 | |
765 | ;; 0 1 2 | |
766 | (define (parse-asctime-date str) | |
767 | (if (not (string-match? str "aaa aaa .d dd:dd:dd dddd")) | |
768 | (bad-header 'date str)) | |
769 | (let ((date (parse-non-negative-integer | |
770 | str | |
771 | (if (eqv? (string-ref str 8) #\space) 9 8) | |
772 | 10)) | |
773 | (month (parse-month str 4 7)) | |
774 | (year (parse-non-negative-integer str 20 24)) | |
775 | (hour (parse-non-negative-integer str 11 13)) | |
776 | (minute (parse-non-negative-integer str 14 16)) | |
777 | (second (parse-non-negative-integer str 17 19))) | |
778 | (make-date 0 second minute hour date month year 0))) | |
779 | ||
440840c1 | 780 | (define (parse-date str) |
2b582a28 AW |
781 | (if (string-suffix? " GMT" str) |
782 | (let ((comma (string-index str #\,))) | |
783 | (cond ((not comma) (bad-header 'date str)) | |
784 | ((= comma 3) (parse-rfc-822-date str)) | |
785 | (else (parse-rfc-850-date str comma)))) | |
786 | (parse-asctime-date str))) | |
440840c1 AW |
787 | |
788 | (define (write-date date port) | |
2b582a28 AW |
789 | (define (display-digits n digits port) |
790 | (define zero (char->integer #\0)) | |
791 | (let lp ((tens (expt 10 (1- digits)))) | |
792 | (if (> tens 0) | |
793 | (begin | |
794 | (display (integer->char (+ zero (modulo (truncate/ n tens) 10))) | |
795 | port) | |
796 | (lp (floor/ tens 10)))))) | |
797 | (let ((date (if (zero? (date-zone-offset date)) | |
798 | date | |
799 | (time-tai->date (date->time-tai date) 0)))) | |
800 | (display (case (date-week-day date) | |
a24885b2 | 801 | ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ") |
2b582a28 AW |
802 | ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ") |
803 | ((6) "Sat, ") (else (error "bad date" date))) | |
804 | port) | |
805 | (display-digits (date-day date) 2 port) | |
806 | (display (case (date-month date) | |
89d45e85 | 807 | ((1) " Jan ") ((2) " Feb ") ((3) " Mar ") |
2b582a28 AW |
808 | ((4) " Apr ") ((5) " May ") ((6) " Jun ") |
809 | ((7) " Jul ") ((8) " Aug ") ((9) " Sep ") | |
810 | ((10) " Oct ") ((11) " Nov ") ((12) " Dec ") | |
811 | (else (error "bad date" date))) | |
812 | port) | |
813 | (display-digits (date-year date) 4 port) | |
814 | (display #\space port) | |
815 | (display-digits (date-hour date) 2 port) | |
816 | (display #\: port) | |
817 | (display-digits (date-minute date) 2 port) | |
818 | (display #\: port) | |
819 | (display-digits (date-second date) 2 port) | |
820 | (display " GMT" port))) | |
440840c1 | 821 | |
440840c1 AW |
822 | (define (parse-entity-tag val) |
823 | (if (string-prefix? "W/" val) | |
824 | (cons (parse-qstring val 2) #f) | |
825 | (cons (parse-qstring val) #t))) | |
826 | ||
827 | (define (entity-tag? val) | |
828 | (and (pair? val) | |
829 | (string? (car val)))) | |
830 | ||
831 | (define (write-entity-tag val port) | |
adcd5854 | 832 | (if (not (cdr val)) |
440840c1 AW |
833 | (display "W/" port)) |
834 | (write-qstring (car val) port)) | |
835 | ||
836 | (define* (parse-entity-tag-list val #:optional | |
837 | (start 0) (end (string-length val))) | |
838 | (let ((strong? (not (string-prefix? "W/" val 0 2 start end)))) | |
839 | (call-with-values (lambda () | |
840 | (parse-qstring val (if strong? start (+ start 2)) | |
841 | end #:incremental? #t)) | |
842 | (lambda (tag next) | |
843 | (acons tag strong? | |
844 | (let ((next (skip-whitespace val next end))) | |
845 | (if (< next end) | |
846 | (if (eqv? (string-ref val next) #\,) | |
847 | (parse-entity-tag-list | |
848 | val | |
849 | (skip-whitespace val (1+ next) end) | |
850 | end) | |
851 | (bad-header-component 'entity-tag-list val)) | |
852 | '()))))))) | |
853 | ||
854 | (define (entity-tag-list? val) | |
855 | (list-of? val entity-tag?)) | |
856 | ||
857 | (define (write-entity-tag-list val port) | |
858 | (write-list val port write-entity-tag ", ")) | |
859 | ||
ecfb7167 AW |
860 | ;; credentials = auth-scheme #auth-param |
861 | ;; auth-scheme = token | |
862 | ;; auth-param = token "=" ( token | quoted-string ) | |
863 | ;; | |
864 | ;; That's what the spec says. In reality the Basic scheme doesn't have | |
865 | ;; k-v pairs, just one auth token, so we give that token as a string. | |
866 | ;; | |
867 | (define* (parse-credentials str #:optional (val-parser default-val-parser) | |
868 | (start 0) (end (string-length str))) | |
869 | (let* ((start (skip-whitespace str start end)) | |
47153f29 | 870 | (delim (or (string-index str char-set:whitespace start end) end))) |
ecfb7167 AW |
871 | (if (= start end) |
872 | (bad-header-component 'authorization str)) | |
873 | (let ((scheme (string->symbol | |
874 | (string-downcase (substring str start (or delim end)))))) | |
875 | (case scheme | |
876 | ((basic) | |
877 | (let* ((start (skip-whitespace str delim end))) | |
878 | (if (< start end) | |
879 | (cons scheme (substring str start end)) | |
880 | (bad-header-component 'credentials str)))) | |
881 | (else | |
882 | (cons scheme (parse-key-value-list str default-val-parser delim end))))))) | |
883 | ||
884 | (define (validate-credentials val) | |
69b8c5df DH |
885 | (and (pair? val) (symbol? (car val)) |
886 | (case (car val) | |
887 | ((basic) (string? (cdr val))) | |
888 | (else (key-value-list? (cdr val)))))) | |
ecfb7167 AW |
889 | |
890 | (define (write-credentials val port) | |
891 | (display (car val) port) | |
892 | (if (pair? (cdr val)) | |
893 | (begin | |
894 | (display #\space port) | |
895 | (write-key-value-list (cdr val) port)))) | |
896 | ||
897 | ;; challenges = 1#challenge | |
898 | ;; challenge = auth-scheme 1*SP 1#auth-param | |
899 | ;; | |
900 | ;; A pain to parse, as both challenges and auth params are delimited by | |
901 | ;; commas, and qstrings can contain anything. We rely on auth params | |
902 | ;; necessarily having "=" in them. | |
903 | ;; | |
904 | (define* (parse-challenge str #:optional | |
905 | (start 0) (end (string-length str))) | |
906 | (let* ((start (skip-whitespace str start end)) | |
907 | (sp (string-index str #\space start end)) | |
908 | (scheme (if sp | |
909 | (string->symbol (string-downcase (substring str start sp))) | |
910 | (bad-header-component 'challenge str)))) | |
911 | (let lp ((i sp) (out (list scheme))) | |
912 | (if (not (< i end)) | |
913 | (values (reverse! out) end) | |
914 | (let* ((i (skip-whitespace str i end)) | |
915 | (eq (string-index str #\= i end)) | |
916 | (comma (string-index str #\, i end)) | |
917 | (delim (min (or eq end) (or comma end))) | |
918 | (token-end (trim-whitespace str i delim))) | |
919 | (if (string-index str #\space i token-end) | |
920 | (values (reverse! out) i) | |
921 | (let ((k (string->symbol (substring str i token-end)))) | |
922 | (call-with-values | |
923 | (lambda () | |
924 | (if (and eq (or (not comma) (< eq comma))) | |
925 | (let ((i (skip-whitespace str (1+ eq) end))) | |
926 | (if (and (< i end) (eqv? (string-ref str i) #\")) | |
927 | (parse-qstring str i end #:incremental? #t) | |
928 | (values (substring | |
929 | str i | |
930 | (trim-whitespace str i | |
931 | (or comma end))) | |
932 | (or comma end)))) | |
933 | (values #f delim))) | |
934 | (lambda (v next-i) | |
935 | (let ((i (skip-whitespace str next-i end))) | |
936 | (if (or (= i end) (eqv? (string-ref str i) #\,)) | |
937 | (lp (1+ i) (cons (if v (cons k v) k) out)) | |
938 | (bad-header-component | |
939 | 'challenge | |
940 | (substring str start end))))))))))))) | |
941 | ||
942 | (define* (parse-challenges str #:optional (val-parser default-val-parser) | |
943 | (start 0) (end (string-length str))) | |
944 | (let lp ((i start) (ret '())) | |
945 | (let ((i (skip-whitespace str i end))) | |
946 | (if (< i end) | |
947 | (call-with-values (lambda () (parse-challenge str i end)) | |
948 | (lambda (challenge i) | |
949 | (lp i (cons challenge ret)))) | |
950 | (reverse ret))))) | |
951 | ||
952 | (define (validate-challenges val) | |
953 | (list-of? val (lambda (x) | |
954 | (and (pair? x) (symbol? (car x)) | |
955 | (key-value-list? (cdr x)))))) | |
956 | ||
957 | (define (write-challenge val port) | |
958 | (display (car val) port) | |
959 | (display #\space port) | |
960 | (write-key-value-list (cdr val) port)) | |
961 | ||
962 | (define (write-challenges val port) | |
963 | (write-list val port write-challenge ", ")) | |
964 | ||
440840c1 AW |
965 | |
966 | \f | |
967 | ||
968 | ;;; | |
969 | ;;; Request-Line and Response-Line | |
970 | ;;; | |
971 | ||
972 | ;; Hmm. | |
973 | (define (bad-request message . args) | |
974 | (throw 'bad-request message args)) | |
975 | (define (bad-response message . args) | |
976 | (throw 'bad-response message args)) | |
977 | ||
978 | (define *known-versions* '()) | |
979 | ||
13b7e2a6 | 980 | (define* (parse-http-version str #:optional (start 0) (end (string-length str))) |
06883ae0 DH |
981 | "Parse an HTTP version from STR, returning it as a major-minor |
982 | pair. For example, ‘HTTP/1.1’ parses as the pair of integers, | |
983 | ‘(1 . 1)’." | |
440840c1 AW |
984 | (or (let lp ((known *known-versions*)) |
985 | (and (pair? known) | |
986 | (if (string= str (caar known) start end) | |
987 | (cdar known) | |
988 | (lp (cdr known))))) | |
989 | (let ((dot-idx (string-index str #\. start end))) | |
990 | (if (and (string-prefix? "HTTP/" str 0 5 start end) | |
991 | dot-idx | |
992 | (= dot-idx (string-rindex str #\. start end))) | |
993 | (cons (parse-non-negative-integer str (+ start 5) dot-idx) | |
994 | (parse-non-negative-integer str (1+ dot-idx) end)) | |
995 | (bad-header-component 'http-version (substring str start end)))))) | |
996 | ||
997 | (define (write-http-version val port) | |
06883ae0 | 998 | "Write the given major-minor version pair to PORT." |
440840c1 AW |
999 | (display "HTTP/" port) |
1000 | (display (car val) port) | |
1001 | (display #\. port) | |
1002 | (display (cdr val) port)) | |
1003 | ||
1004 | (for-each | |
1005 | (lambda (v) | |
1006 | (set! *known-versions* | |
1007 | (acons v (parse-http-version v 0 (string-length v)) | |
1008 | *known-versions*))) | |
1009 | '("HTTP/1.0" "HTTP/1.1")) | |
1010 | ||
1011 | ||
1012 | ;; Request-URI = "*" | absoluteURI | abs_path | authority | |
1013 | ;; | |
1014 | ;; The `authority' form is only permissible for the CONNECT method, so | |
1015 | ;; because we don't expect people to implement CONNECT, we save | |
1016 | ;; ourselves the trouble of that case, and disallow the CONNECT method. | |
1017 | ;; | |
13b7e2a6 | 1018 | (define* (parse-http-method str #:optional (start 0) (end (string-length str))) |
06883ae0 DH |
1019 | "Parse an HTTP method from STR. The result is an upper-case |
1020 | symbol, like ‘GET’." | |
440840c1 AW |
1021 | (cond |
1022 | ((string= str "GET" start end) 'GET) | |
1023 | ((string= str "HEAD" start end) 'HEAD) | |
1024 | ((string= str "POST" start end) 'POST) | |
1025 | ((string= str "PUT" start end) 'PUT) | |
1026 | ((string= str "DELETE" start end) 'DELETE) | |
1027 | ((string= str "OPTIONS" start end) 'OPTIONS) | |
1028 | ((string= str "TRACE" start end) 'TRACE) | |
1029 | (else (bad-request "Invalid method: ~a" (substring str start end))))) | |
1030 | ||
13b7e2a6 | 1031 | (define* (parse-request-uri str #:optional (start 0) (end (string-length str))) |
92c5c0b6 AW |
1032 | "Parse a URI from an HTTP request line. Note that URIs in requests do |
1033 | not have to have a scheme or host name. The result is a URI object." | |
440840c1 AW |
1034 | (cond |
1035 | ((= start end) | |
1036 | (bad-request "Missing Request-URI")) | |
1037 | ((string= str "*" start end) | |
1038 | #f) | |
1039 | ((eq? (string-ref str start) #\/) | |
1040 | (let* ((q (string-index str #\? start end)) | |
1041 | (f (string-index str #\# start end)) | |
1042 | (q (and q (or (not f) (< q f)) q))) | |
1043 | (build-uri 'http | |
1044 | #:path (substring str start (or q f end)) | |
1045 | #:query (and q (substring str (1+ q) (or f end))) | |
1046 | #:fragment (and f (substring str (1+ f) end))))) | |
1047 | (else | |
8745c33a | 1048 | (or (string->uri (substring str start end)) |
440840c1 AW |
1049 | (bad-request "Invalid URI: ~a" (substring str start end)))))) |
1050 | ||
1051 | (define (read-request-line port) | |
06883ae0 | 1052 | "Read the first line of an HTTP request from PORT, returning |
92c5c0b6 | 1053 | three values: the method, the URI, and the version." |
440840c1 | 1054 | (let* ((line (read-line* port)) |
47153f29 AW |
1055 | (d0 (string-index line char-set:whitespace)) ; "delimiter zero" |
1056 | (d1 (string-rindex line char-set:whitespace))) | |
440840c1 | 1057 | (if (and d0 d1 (< d0 d1)) |
13b7e2a6 AW |
1058 | (values (parse-http-method line 0 d0) |
1059 | (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1) | |
440840c1 AW |
1060 | (parse-http-version line (1+ d1) (string-length line))) |
1061 | (bad-request "Bad Request-Line: ~s" line)))) | |
1062 | ||
1063 | (define (write-uri uri port) | |
1064 | (if (uri-host uri) | |
1065 | (begin | |
1066 | (display (uri-scheme uri) port) | |
1067 | (display "://" port) | |
1068 | (if (uri-userinfo uri) | |
1069 | (begin | |
1070 | (display (uri-userinfo uri) port) | |
1071 | (display #\@ port))) | |
1072 | (display (uri-host uri) port) | |
1073 | (let ((p (uri-port uri))) | |
1074 | (if (and p (not (eqv? p 80))) | |
1075 | (begin | |
1076 | (display #\: port) | |
1077 | (display p port)))))) | |
1078 | (let* ((path (uri-path uri)) | |
1079 | (len (string-length path))) | |
1080 | (cond | |
1081 | ((and (> len 0) (not (eqv? (string-ref path 0) #\/))) | |
1082 | (bad-request "Non-absolute URI path: ~s" path)) | |
1083 | ((and (zero? len) (not (uri-host uri))) | |
1084 | (bad-request "Empty path and no host for URI: ~s" uri)) | |
1085 | (else | |
1086 | (display path port)))) | |
1087 | (if (uri-query uri) | |
1088 | (begin | |
1089 | (display #\? port) | |
1090 | (display (uri-query uri) port)))) | |
1091 | ||
1092 | (define (write-request-line method uri version port) | |
06883ae0 | 1093 | "Write the first line of an HTTP request to PORT." |
440840c1 AW |
1094 | (display method port) |
1095 | (display #\space port) | |
ab66fb3c IP |
1096 | (let ((path (uri-path uri)) |
1097 | (query (uri-query uri))) | |
1098 | (if (not (string-null? path)) | |
1099 | (display path port)) | |
1100 | (if query | |
1101 | (begin | |
1102 | (display "?" port) | |
1103 | (display query port))) | |
1104 | (if (and (string-null? path) | |
1105 | (not query)) | |
1106 | ;; Make sure we display something. | |
1107 | (display "/" port))) | |
440840c1 AW |
1108 | (display #\space port) |
1109 | (write-http-version version port) | |
1110 | (display "\r\n" port)) | |
1111 | ||
1112 | (define (read-response-line port) | |
06883ae0 | 1113 | "Read the first line of an HTTP response from PORT, returning |
92c5c0b6 AW |
1114 | three values: the HTTP version, the response code, and the \"reason |
1115 | phrase\"." | |
440840c1 | 1116 | (let* ((line (read-line* port)) |
47153f29 AW |
1117 | (d0 (string-index line char-set:whitespace)) ; "delimiter zero" |
1118 | (d1 (and d0 (string-index line char-set:whitespace | |
440840c1 AW |
1119 | (skip-whitespace line d0))))) |
1120 | (if (and d0 d1) | |
1121 | (values (parse-http-version line 0 d0) | |
1122 | (parse-non-negative-integer line (skip-whitespace line d0 d1) | |
1123 | d1) | |
47153f29 | 1124 | (string-trim-both line char-set:whitespace d1)) |
440840c1 AW |
1125 | (bad-response "Bad Response-Line: ~s" line)))) |
1126 | ||
1127 | (define (write-response-line version code reason-phrase port) | |
06883ae0 | 1128 | "Write the first line of an HTTP response to PORT." |
440840c1 AW |
1129 | (write-http-version version port) |
1130 | (display #\space port) | |
1131 | (display code port) | |
1132 | (display #\space port) | |
1133 | (display reason-phrase port) | |
1134 | (display "\r\n" port)) | |
1135 | ||
1136 | ||
1137 | \f | |
1138 | ||
1139 | ;;; | |
be1be3e5 | 1140 | ;;; Helpers for declaring headers |
440840c1 AW |
1141 | ;;; |
1142 | ||
be1be3e5 AW |
1143 | ;; emacs: (put 'declare-header! 'scheme-indent-function 1) |
1144 | ;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1) | |
1145 | (define (declare-opaque-header! name) | |
64ead01d IP |
1146 | "Declares a given header as \"opaque\", meaning that its value is not |
1147 | treated specially, and is just returned as a plain string." | |
be1be3e5 AW |
1148 | (declare-header! name |
1149 | parse-opaque-string validate-opaque-string write-opaque-string)) | |
1150 | ||
1151 | ;; emacs: (put 'declare-date-header! 'scheme-indent-function 1) | |
1152 | (define (declare-date-header! name) | |
1153 | (declare-header! name | |
1154 | parse-date date? write-date)) | |
1155 | ||
1156 | ;; emacs: (put 'declare-string-list-header! 'scheme-indent-function 1) | |
1157 | (define (declare-string-list-header! name) | |
1158 | (declare-header! name | |
1159 | split-and-trim list-of-strings? write-list-of-strings)) | |
1160 | ||
94f16a5b AW |
1161 | ;; emacs: (put 'declare-symbol-list-header! 'scheme-indent-function 1) |
1162 | (define (declare-symbol-list-header! name) | |
1163 | (declare-header! name | |
1164 | (lambda (str) | |
1165 | (map string->symbol (split-and-trim str))) | |
1166 | (lambda (v) | |
69b8c5df | 1167 | (list-of? v symbol?)) |
94f16a5b AW |
1168 | (lambda (v port) |
1169 | (write-list v port display ", ")))) | |
1170 | ||
be1be3e5 AW |
1171 | ;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1) |
1172 | (define (declare-header-list-header! name) | |
1173 | (declare-header! name | |
1174 | split-header-names list-of-header-names? write-header-list)) | |
1175 | ||
1176 | ;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1) | |
1177 | (define (declare-integer-header! name) | |
1178 | (declare-header! name | |
1179 | parse-non-negative-integer non-negative-integer? display)) | |
1180 | ||
1181 | ;; emacs: (put 'declare-uri-header! 'scheme-indent-function 1) | |
1182 | (define (declare-uri-header! name) | |
1183 | (declare-header! name | |
1184 | (lambda (str) (or (string->uri str) (bad-header-component 'uri str))) | |
4e81e9d9 | 1185 | (@@ (web uri) absolute-uri?) |
be1be3e5 AW |
1186 | write-uri)) |
1187 | ||
261af760 LC |
1188 | ;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1) |
1189 | (define (declare-relative-uri-header! name) | |
1190 | (declare-header! name | |
1191 | (lambda (str) | |
4e81e9d9 DH |
1192 | (or ((@@ (web uri) string->uri*) str) |
1193 | (bad-header-component 'uri str))) | |
261af760 LC |
1194 | uri? |
1195 | write-uri)) | |
1196 | ||
be1be3e5 AW |
1197 | ;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1) |
1198 | (define (declare-quality-list-header! name) | |
1199 | (declare-header! name | |
1200 | parse-quality-list validate-quality-list write-quality-list)) | |
1201 | ||
1202 | ;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1) | |
1203 | (define* (declare-param-list-header! name #:optional | |
0acc595b AW |
1204 | (val-parser default-val-parser) |
1205 | (val-validator default-val-validator) | |
be1be3e5 AW |
1206 | (val-writer default-val-writer)) |
1207 | (declare-header! name | |
0acc595b | 1208 | (lambda (str) (parse-param-list str val-parser)) |
be1be3e5 AW |
1209 | (lambda (val) (validate-param-list val val-validator)) |
1210 | (lambda (val port) (write-param-list val port val-writer)))) | |
1211 | ||
1212 | ;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1) | |
1213 | (define* (declare-key-value-list-header! name #:optional | |
0acc595b AW |
1214 | (val-parser default-val-parser) |
1215 | (val-validator default-val-validator) | |
be1be3e5 AW |
1216 | (val-writer default-val-writer)) |
1217 | (declare-header! name | |
0acc595b | 1218 | (lambda (str) (parse-key-value-list str val-parser)) |
be1be3e5 AW |
1219 | (lambda (val) (key-value-list? val val-validator)) |
1220 | (lambda (val port) (write-key-value-list val port val-writer)))) | |
1221 | ||
1222 | ;; emacs: (put 'declare-entity-tag-list-header! 'scheme-indent-function 1) | |
1223 | (define (declare-entity-tag-list-header! name) | |
1224 | (declare-header! name | |
1225 | (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str))) | |
1226 | (lambda (val) (or (eq? val '*) (entity-tag-list? val))) | |
1227 | (lambda (val port) | |
1228 | (if (eq? val '*) | |
1229 | (display "*" port) | |
1230 | (write-entity-tag-list val port))))) | |
440840c1 | 1231 | |
ecfb7167 AW |
1232 | ;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1) |
1233 | (define (declare-credentials-header! name) | |
1234 | (declare-header! name | |
1235 | parse-credentials validate-credentials write-credentials)) | |
1236 | ||
1237 | ;; emacs: (put 'declare-challenge-list-header! 'scheme-indent-function 1) | |
1238 | (define (declare-challenge-list-header! name) | |
1239 | (declare-header! name | |
1240 | parse-challenges validate-challenges write-challenges)) | |
1241 | ||
440840c1 AW |
1242 | |
1243 | \f | |
1244 | ||
1245 | ;;; | |
1246 | ;;; General headers | |
1247 | ;;; | |
1248 | ||
1249 | ;; Cache-Control = 1#(cache-directive) | |
1250 | ;; cache-directive = cache-request-directive | cache-response-directive | |
1251 | ;; cache-request-directive = | |
1252 | ;; "no-cache" ; Section 14.9.1 | |
1253 | ;; | "no-store" ; Section 14.9.2 | |
1254 | ;; | "max-age" "=" delta-seconds ; Section 14.9.3, 14.9.4 | |
1255 | ;; | "max-stale" [ "=" delta-seconds ] ; Section 14.9.3 | |
1256 | ;; | "min-fresh" "=" delta-seconds ; Section 14.9.3 | |
1257 | ;; | "no-transform" ; Section 14.9.5 | |
1258 | ;; | "only-if-cached" ; Section 14.9.4 | |
1259 | ;; | cache-extension ; Section 14.9.6 | |
1260 | ;; cache-response-directive = | |
1261 | ;; "public" ; Section 14.9.1 | |
1262 | ;; | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1 | |
1263 | ;; | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1 | |
1264 | ;; | "no-store" ; Section 14.9.2 | |
1265 | ;; | "no-transform" ; Section 14.9.5 | |
1266 | ;; | "must-revalidate" ; Section 14.9.4 | |
1267 | ;; | "proxy-revalidate" ; Section 14.9.4 | |
1268 | ;; | "max-age" "=" delta-seconds ; Section 14.9.3 | |
1269 | ;; | "s-maxage" "=" delta-seconds ; Section 14.9.3 | |
1270 | ;; | cache-extension ; Section 14.9.6 | |
1271 | ;; cache-extension = token [ "=" ( token | quoted-string ) ] | |
1272 | ;; | |
be1be3e5 | 1273 | (declare-key-value-list-header! "Cache-Control" |
440840c1 AW |
1274 | (lambda (k v-str) |
1275 | (case k | |
321770b2 | 1276 | ((max-age min-fresh s-maxage) |
0acc595b | 1277 | (parse-non-negative-integer v-str)) |
321770b2 DH |
1278 | ((max-stale) |
1279 | (and v-str (parse-non-negative-integer v-str))) | |
440840c1 | 1280 | ((private no-cache) |
0acc595b AW |
1281 | (and v-str (split-header-names v-str))) |
1282 | (else v-str))) | |
69b8c5df DH |
1283 | (lambda (k v) |
1284 | (case k | |
321770b2 | 1285 | ((max-age min-fresh s-maxage) |
69b8c5df | 1286 | (non-negative-integer? v)) |
321770b2 DH |
1287 | ((max-stale) |
1288 | (or (not v) (non-negative-integer? v))) | |
69b8c5df DH |
1289 | ((private no-cache) |
1290 | (or (not v) (list-of-header-names? v))) | |
321770b2 DH |
1291 | ((no-store no-transform only-if-cache must-revalidate proxy-revalidate) |
1292 | (not v)) | |
69b8c5df | 1293 | (else |
321770b2 | 1294 | (or (not v) (string? v))))) |
440840c1 AW |
1295 | (lambda (k v port) |
1296 | (cond | |
61fe8eaf | 1297 | ((string? v) (default-val-writer k v port)) |
440840c1 | 1298 | ((pair? v) |
adc91e41 AW |
1299 | (display #\" port) |
1300 | (write-header-list v port) | |
1301 | (display #\" port)) | |
440840c1 AW |
1302 | ((integer? v) |
1303 | (display v port)) | |
1304 | (else | |
1305 | (bad-header-component 'cache-control v))))) | |
1306 | ||
1307 | ;; Connection = "Connection" ":" 1#(connection-token) | |
1308 | ;; connection-token = token | |
1309 | ;; e.g. | |
1310 | ;; Connection: close, foo-header | |
1311 | ;; | |
94f16a5b | 1312 | (declare-header-list-header! "Connection") |
440840c1 AW |
1313 | |
1314 | ;; Date = "Date" ":" HTTP-date | |
1315 | ;; e.g. | |
1316 | ;; Date: Tue, 15 Nov 1994 08:12:31 GMT | |
1317 | ;; | |
be1be3e5 | 1318 | (declare-date-header! "Date") |
440840c1 AW |
1319 | |
1320 | ;; Pragma = "Pragma" ":" 1#pragma-directive | |
1321 | ;; pragma-directive = "no-cache" | extension-pragma | |
1322 | ;; extension-pragma = token [ "=" ( token | quoted-string ) ] | |
1323 | ;; | |
0acc595b | 1324 | (declare-key-value-list-header! "Pragma") |
440840c1 AW |
1325 | |
1326 | ;; Trailer = "Trailer" ":" 1#field-name | |
1327 | ;; | |
be1be3e5 | 1328 | (declare-header-list-header! "Trailer") |
440840c1 AW |
1329 | |
1330 | ;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding | |
1331 | ;; | |
0acc595b | 1332 | (declare-param-list-header! "Transfer-Encoding") |
440840c1 AW |
1333 | |
1334 | ;; Upgrade = "Upgrade" ":" 1#product | |
1335 | ;; | |
be1be3e5 | 1336 | (declare-string-list-header! "Upgrade") |
440840c1 AW |
1337 | |
1338 | ;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] ) | |
1339 | ;; received-protocol = [ protocol-name "/" ] protocol-version | |
1340 | ;; protocol-name = token | |
1341 | ;; protocol-version = token | |
1342 | ;; received-by = ( host [ ":" port ] ) | pseudonym | |
1343 | ;; pseudonym = token | |
1344 | ;; | |
be1be3e5 | 1345 | (declare-header! "Via" |
440840c1 AW |
1346 | split-and-trim |
1347 | list-of-strings? | |
1348 | write-list-of-strings | |
1349 | #:multiple? #t) | |
1350 | ||
1351 | ;; Warning = "Warning" ":" 1#warning-value | |
1352 | ;; | |
1353 | ;; warning-value = warn-code SP warn-agent SP warn-text | |
1354 | ;; [SP warn-date] | |
1355 | ;; | |
1356 | ;; warn-code = 3DIGIT | |
1357 | ;; warn-agent = ( host [ ":" port ] ) | pseudonym | |
1358 | ;; ; the name or pseudonym of the server adding | |
1359 | ;; ; the Warning header, for use in debugging | |
1360 | ;; warn-text = quoted-string | |
1361 | ;; warn-date = <"> HTTP-date <"> | |
be1be3e5 | 1362 | (declare-header! "Warning" |
440840c1 AW |
1363 | (lambda (str) |
1364 | (let ((len (string-length str))) | |
1365 | (let lp ((i (skip-whitespace str 0))) | |
1366 | (let* ((idx1 (string-index str #\space i)) | |
1367 | (idx2 (string-index str #\space (1+ idx1)))) | |
1368 | (if (and idx1 idx2) | |
1369 | (let ((code (parse-non-negative-integer str i idx1)) | |
1370 | (agent (substring str (1+ idx1) idx2))) | |
1371 | (call-with-values | |
1372 | (lambda () (parse-qstring str (1+ idx2) #:incremental? #t)) | |
1373 | (lambda (text i) | |
1374 | (call-with-values | |
1375 | (lambda () | |
1376 | (let ((c (and (< i len) (string-ref str i)))) | |
1377 | (case c | |
1378 | ((#\space) | |
1379 | ;; we have a date. | |
1380 | (call-with-values | |
1381 | (lambda () (parse-qstring str (1+ i) | |
1382 | #:incremental? #t)) | |
1383 | (lambda (date i) | |
1384 | (values text (parse-date date) i)))) | |
1385 | (else | |
1386 | (values text #f i))))) | |
1387 | (lambda (text date i) | |
1388 | (let ((w (list code agent text date)) | |
1389 | (c (and (< i len) (string-ref str i)))) | |
1390 | (case c | |
1391 | ((#f) (list w)) | |
1392 | ((#\,) (cons w (lp (skip-whitespace str (1+ i))))) | |
1393 | (else (bad-header 'warning str)))))))))))))) | |
1394 | (lambda (val) | |
1395 | (list-of? val | |
1396 | (lambda (elt) | |
1397 | (and (list? elt) | |
1398 | (= (length elt) 4) | |
1399 | (apply (lambda (code host text date) | |
1400 | (and (non-negative-integer? code) (< code 1000) | |
1401 | (string? host) | |
1402 | (string? text) | |
1403 | (or (not date) (date? date)))) | |
1404 | elt))))) | |
1405 | (lambda (val port) | |
1406 | (write-list | |
1407 | val port | |
1408 | (lambda (w port) | |
1409 | (apply | |
1410 | (lambda (code host text date) | |
1411 | (display code port) | |
1412 | (display #\space port) | |
1413 | (display host port) | |
1414 | (display #\space port) | |
1415 | (write-qstring text port) | |
1416 | (if date | |
1417 | (begin | |
1418 | (display #\space port) | |
1419 | (write-date date port)))) | |
1420 | w)) | |
1421 | ", ")) | |
1422 | #:multiple? #t) | |
1423 | ||
1424 | ||
1425 | \f | |
1426 | ||
1427 | ;;; | |
1428 | ;;; Entity headers | |
1429 | ;;; | |
1430 | ||
1431 | ;; Allow = #Method | |
1432 | ;; | |
94f16a5b | 1433 | (declare-symbol-list-header! "Allow") |
440840c1 AW |
1434 | |
1435 | ;; Content-Encoding = 1#content-coding | |
1436 | ;; | |
94f16a5b | 1437 | (declare-symbol-list-header! "Content-Encoding") |
440840c1 AW |
1438 | |
1439 | ;; Content-Language = 1#language-tag | |
1440 | ;; | |
be1be3e5 | 1441 | (declare-string-list-header! "Content-Language") |
440840c1 AW |
1442 | |
1443 | ;; Content-Length = 1*DIGIT | |
1444 | ;; | |
be1be3e5 | 1445 | (declare-integer-header! "Content-Length") |
440840c1 AW |
1446 | |
1447 | ;; Content-Location = ( absoluteURI | relativeURI ) | |
1448 | ;; | |
261af760 | 1449 | (declare-relative-uri-header! "Content-Location") |
440840c1 AW |
1450 | |
1451 | ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864> | |
1452 | ;; | |
be1be3e5 | 1453 | (declare-opaque-header! "Content-MD5") |
440840c1 AW |
1454 | |
1455 | ;; Content-Range = content-range-spec | |
1456 | ;; content-range-spec = byte-content-range-spec | |
1457 | ;; byte-content-range-spec = bytes-unit SP | |
1458 | ;; byte-range-resp-spec "/" | |
1459 | ;; ( instance-length | "*" ) | |
1460 | ;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos) | |
1461 | ;; | "*" | |
1462 | ;; instance-length = 1*DIGIT | |
1463 | ;; | |
be1be3e5 | 1464 | (declare-header! "Content-Range" |
440840c1 AW |
1465 | (lambda (str) |
1466 | (let ((dash (string-index str #\-)) | |
1467 | (slash (string-index str #\/))) | |
1468 | (if (and (string-prefix? "bytes " str) slash) | |
1469 | (list 'bytes | |
1470 | (cond | |
1471 | (dash | |
1472 | (cons | |
1473 | (parse-non-negative-integer str 6 dash) | |
1474 | (parse-non-negative-integer str (1+ dash) slash))) | |
1475 | ((string= str "*" 6 slash) | |
1476 | '*) | |
1477 | (else | |
1478 | (bad-header 'content-range str))) | |
1479 | (if (string= str "*" (1+ slash)) | |
1480 | '* | |
1481 | (parse-non-negative-integer str (1+ slash)))) | |
1482 | (bad-header 'content-range str)))) | |
1483 | (lambda (val) | |
1484 | (and (list? val) (= (length val) 3) | |
1485 | (symbol? (car val)) | |
1486 | (let ((x (cadr val))) | |
1487 | (or (eq? x '*) | |
1488 | (and (pair? x) | |
1489 | (non-negative-integer? (car x)) | |
1490 | (non-negative-integer? (cdr x))))) | |
1491 | (let ((x (caddr val))) | |
1492 | (or (eq? x '*) | |
1493 | (non-negative-integer? x))))) | |
1494 | (lambda (val port) | |
1495 | (display (car val) port) | |
1496 | (display #\space port) | |
1497 | (if (eq? (cadr val) '*) | |
1498 | (display #\* port) | |
1499 | (begin | |
1500 | (display (caadr val) port) | |
1501 | (display #\- port) | |
1502 | (display (caadr val) port))) | |
1503 | (if (eq? (caddr val) '*) | |
1504 | (display #\* port) | |
1505 | (display (caddr val) port)))) | |
1506 | ||
1507 | ;; Content-Type = media-type | |
1508 | ;; | |
be1be3e5 | 1509 | (declare-header! "Content-Type" |
440840c1 AW |
1510 | (lambda (str) |
1511 | (let ((parts (string-split str #\;))) | |
7aa54882 AW |
1512 | (cons (parse-media-type (car parts)) |
1513 | (map (lambda (x) | |
1514 | (let ((eq (string-index x #\=))) | |
1515 | (if (and eq (= eq (string-rindex x #\=))) | |
47153f29 AW |
1516 | (cons |
1517 | (string->symbol | |
1518 | (string-trim x char-set:whitespace 0 eq)) | |
1519 | (string-trim-right x char-set:whitespace (1+ eq))) | |
7aa54882 AW |
1520 | (bad-header 'content-type str)))) |
1521 | (cdr parts))))) | |
440840c1 | 1522 | (lambda (val) |
7aa54882 | 1523 | (and (pair? val) |
0acc595b | 1524 | (symbol? (car val)) |
7aa54882 AW |
1525 | (list-of? (cdr val) |
1526 | (lambda (x) | |
0acc595b | 1527 | (and (pair? x) (symbol? (car x)) (string? (cdr x))))))) |
440840c1 AW |
1528 | (lambda (val port) |
1529 | (display (car val) port) | |
7aa54882 AW |
1530 | (if (pair? (cdr val)) |
1531 | (begin | |
1532 | (display ";" port) | |
1533 | (write-list | |
1534 | (cdr val) port | |
1535 | (lambda (pair port) | |
1536 | (display (car pair) port) | |
1537 | (display #\= port) | |
1538 | (display (cdr pair) port)) | |
1539 | ";"))))) | |
440840c1 AW |
1540 | |
1541 | ;; Expires = HTTP-date | |
1542 | ;; | |
0e947e1d DH |
1543 | (define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT")) |
1544 | ||
1545 | (declare-header! "Expires" | |
1546 | (lambda (str) | |
1547 | (if (member str '("0" "-1")) | |
1548 | *date-in-the-past* | |
1549 | (parse-date str))) | |
1550 | date? | |
1551 | write-date) | |
440840c1 AW |
1552 | |
1553 | ;; Last-Modified = HTTP-date | |
1554 | ;; | |
be1be3e5 | 1555 | (declare-date-header! "Last-Modified") |
440840c1 AW |
1556 | |
1557 | ||
1558 | \f | |
1559 | ||
1560 | ;;; | |
1561 | ;;; Request headers | |
1562 | ;;; | |
1563 | ||
1564 | ;; Accept = #( media-range [ accept-params ] ) | |
1565 | ;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) ) | |
1566 | ;; *( ";" parameter ) | |
1567 | ;; accept-params = ";" "q" "=" qvalue *( accept-extension ) | |
1568 | ;; accept-extension = ";" token [ "=" ( token | quoted-string ) ] | |
1569 | ;; | |
be1be3e5 | 1570 | (declare-param-list-header! "Accept" |
0acc595b | 1571 | ;; -> (type/subtype (sym-prop . str-val) ...) ...) |
440840c1 | 1572 | ;; |
0acc595b AW |
1573 | ;; with the exception of prop `q', in which case the val will be a |
1574 | ;; valid quality value | |
440840c1 | 1575 | ;; |
440840c1 | 1576 | (lambda (k v) |
0acc595b AW |
1577 | (if (eq? k 'q) |
1578 | (parse-quality v) | |
1579 | v)) | |
440840c1 AW |
1580 | (lambda (k v) |
1581 | (if (eq? k 'q) | |
1582 | (valid-quality? v) | |
69b8c5df | 1583 | (or (not v) (string? v)))) |
440840c1 AW |
1584 | (lambda (k v port) |
1585 | (if (eq? k 'q) | |
1586 | (write-quality v port) | |
1587 | (default-val-writer k v port)))) | |
1588 | ||
1589 | ;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] ) | |
1590 | ;; | |
be1be3e5 | 1591 | (declare-quality-list-header! "Accept-Charset") |
440840c1 AW |
1592 | |
1593 | ;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] ) | |
1594 | ;; codings = ( content-coding | "*" ) | |
1595 | ;; | |
be1be3e5 | 1596 | (declare-quality-list-header! "Accept-Encoding") |
440840c1 AW |
1597 | |
1598 | ;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] ) | |
1599 | ;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" ) | |
1600 | ;; | |
be1be3e5 | 1601 | (declare-quality-list-header! "Accept-Language") |
440840c1 AW |
1602 | |
1603 | ;; Authorization = credentials | |
ecfb7167 AW |
1604 | ;; credentials = auth-scheme #auth-param |
1605 | ;; auth-scheme = token | |
1606 | ;; auth-param = token "=" ( token | quoted-string ) | |
440840c1 | 1607 | ;; |
ecfb7167 | 1608 | (declare-credentials-header! "Authorization") |
440840c1 AW |
1609 | |
1610 | ;; Expect = 1#expectation | |
1611 | ;; expectation = "100-continue" | expectation-extension | |
1612 | ;; expectation-extension = token [ "=" ( token | quoted-string ) | |
1613 | ;; *expect-params ] | |
1614 | ;; expect-params = ";" token [ "=" ( token | quoted-string ) ] | |
1615 | ;; | |
0acc595b | 1616 | (declare-param-list-header! "Expect") |
440840c1 AW |
1617 | |
1618 | ;; From = mailbox | |
1619 | ;; | |
1620 | ;; Should be an email address; we just pass on the string as-is. | |
1621 | ;; | |
be1be3e5 | 1622 | (declare-opaque-header! "From") |
440840c1 AW |
1623 | |
1624 | ;; Host = host [ ":" port ] | |
1625 | ;; | |
be1be3e5 | 1626 | (declare-header! "Host" |
440840c1 AW |
1627 | (lambda (str) |
1628 | (let ((colon (string-index str #\:))) | |
1629 | (if colon | |
1630 | (cons (substring str 0 colon) | |
1631 | (parse-non-negative-integer str (1+ colon))) | |
1632 | (cons str #f)))) | |
1633 | (lambda (val) | |
1634 | (and (pair? val) | |
1635 | (string? (car val)) | |
1636 | (or (not (cdr val)) | |
1637 | (non-negative-integer? (cdr val))))) | |
1638 | (lambda (val port) | |
1639 | (display (car val) port) | |
1640 | (if (cdr val) | |
1641 | (begin | |
1642 | (display #\: port) | |
1643 | (display (cdr val) port))))) | |
1644 | ||
1645 | ;; If-Match = ( "*" | 1#entity-tag ) | |
1646 | ;; | |
be1be3e5 | 1647 | (declare-entity-tag-list-header! "If-Match") |
440840c1 AW |
1648 | |
1649 | ;; If-Modified-Since = HTTP-date | |
1650 | ;; | |
be1be3e5 | 1651 | (declare-date-header! "If-Modified-Since") |
440840c1 AW |
1652 | |
1653 | ;; If-None-Match = ( "*" | 1#entity-tag ) | |
1654 | ;; | |
be1be3e5 | 1655 | (declare-entity-tag-list-header! "If-None-Match") |
440840c1 AW |
1656 | |
1657 | ;; If-Range = ( entity-tag | HTTP-date ) | |
1658 | ;; | |
be1be3e5 | 1659 | (declare-header! "If-Range" |
440840c1 AW |
1660 | (lambda (str) |
1661 | (if (or (string-prefix? "\"" str) | |
1662 | (string-prefix? "W/" str)) | |
1663 | (parse-entity-tag str) | |
1664 | (parse-date str))) | |
1665 | (lambda (val) | |
1666 | (or (date? val) (entity-tag? val))) | |
1667 | (lambda (val port) | |
1668 | (if (date? val) | |
1669 | (write-date val port) | |
1670 | (write-entity-tag val port)))) | |
1671 | ||
1672 | ;; If-Unmodified-Since = HTTP-date | |
1673 | ;; | |
be1be3e5 | 1674 | (declare-date-header! "If-Unmodified-Since") |
440840c1 AW |
1675 | |
1676 | ;; Max-Forwards = 1*DIGIT | |
1677 | ;; | |
be1be3e5 | 1678 | (declare-integer-header! "Max-Forwards") |
440840c1 AW |
1679 | |
1680 | ;; Proxy-Authorization = credentials | |
1681 | ;; | |
ecfb7167 | 1682 | (declare-credentials-header! "Proxy-Authorization") |
440840c1 AW |
1683 | |
1684 | ;; Range = "Range" ":" ranges-specifier | |
1685 | ;; ranges-specifier = byte-ranges-specifier | |
1686 | ;; byte-ranges-specifier = bytes-unit "=" byte-range-set | |
1687 | ;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec ) | |
1688 | ;; byte-range-spec = first-byte-pos "-" [last-byte-pos] | |
1689 | ;; first-byte-pos = 1*DIGIT | |
1690 | ;; last-byte-pos = 1*DIGIT | |
1691 | ;; suffix-byte-range-spec = "-" suffix-length | |
1692 | ;; suffix-length = 1*DIGIT | |
1693 | ;; | |
be1be3e5 | 1694 | (declare-header! "Range" |
440840c1 AW |
1695 | (lambda (str) |
1696 | (if (string-prefix? "bytes=" str) | |
1697 | (cons | |
1698 | 'bytes | |
1699 | (map (lambda (x) | |
1700 | (let ((dash (string-index x #\-))) | |
1701 | (cond | |
1702 | ((not dash) | |
1703 | (bad-header 'range str)) | |
1704 | ((zero? dash) | |
1705 | (cons #f (parse-non-negative-integer x 1))) | |
1706 | ((= dash (1- (string-length x))) | |
1707 | (cons (parse-non-negative-integer x 0 dash) #f)) | |
1708 | (else | |
1709 | (cons (parse-non-negative-integer x 0 dash) | |
1710 | (parse-non-negative-integer x (1+ dash))))))) | |
1711 | (string-split (substring str 6) #\,))) | |
1712 | (bad-header 'range str))) | |
1713 | (lambda (val) | |
1714 | (and (pair? val) | |
1715 | (symbol? (car val)) | |
1716 | (list-of? (cdr val) | |
1717 | (lambda (elt) | |
1718 | (and (pair? elt) | |
1719 | (let ((x (car elt)) (y (cdr elt))) | |
1720 | (and (or x y) | |
1721 | (or (not x) (non-negative-integer? x)) | |
1722 | (or (not y) (non-negative-integer? y))))))))) | |
1723 | (lambda (val port) | |
1724 | (display (car val) port) | |
1725 | (display #\= port) | |
1726 | (write-list | |
1727 | (cdr val) port | |
1728 | (lambda (pair port) | |
1729 | (if (car pair) | |
1730 | (display (car pair) port)) | |
1731 | (display #\- port) | |
1732 | (if (cdr pair) | |
1733 | (display (cdr pair) port))) | |
1734 | ","))) | |
1735 | ||
1736 | ;; Referer = ( absoluteURI | relativeURI ) | |
1737 | ;; | |
261af760 | 1738 | (declare-relative-uri-header! "Referer") |
440840c1 AW |
1739 | |
1740 | ;; TE = #( t-codings ) | |
1741 | ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) | |
1742 | ;; | |
0acc595b | 1743 | (declare-param-list-header! "TE") |
440840c1 AW |
1744 | |
1745 | ;; User-Agent = 1*( product | comment ) | |
1746 | ;; | |
be1be3e5 | 1747 | (declare-opaque-header! "User-Agent") |
440840c1 AW |
1748 | |
1749 | ||
1750 | \f | |
1751 | ||
1752 | ;;; | |
1753 | ;;; Reponse headers | |
1754 | ;;; | |
1755 | ||
1756 | ;; Accept-Ranges = acceptable-ranges | |
1757 | ;; acceptable-ranges = 1#range-unit | "none" | |
1758 | ;; | |
94f16a5b | 1759 | (declare-symbol-list-header! "Accept-Ranges") |
440840c1 AW |
1760 | |
1761 | ;; Age = age-value | |
1762 | ;; age-value = delta-seconds | |
1763 | ;; | |
be1be3e5 | 1764 | (declare-integer-header! "Age") |
440840c1 AW |
1765 | |
1766 | ;; ETag = entity-tag | |
1767 | ;; | |
be1be3e5 | 1768 | (declare-header! "ETag" |
440840c1 AW |
1769 | parse-entity-tag |
1770 | entity-tag? | |
1771 | write-entity-tag) | |
1772 | ||
1773 | ;; Location = absoluteURI | |
1774 | ;; | |
be1be3e5 | 1775 | (declare-uri-header! "Location") |
440840c1 AW |
1776 | |
1777 | ;; Proxy-Authenticate = 1#challenge | |
1778 | ;; | |
ecfb7167 | 1779 | (declare-challenge-list-header! "Proxy-Authenticate") |
440840c1 AW |
1780 | |
1781 | ;; Retry-After = ( HTTP-date | delta-seconds ) | |
1782 | ;; | |
be1be3e5 | 1783 | (declare-header! "Retry-After" |
440840c1 AW |
1784 | (lambda (str) |
1785 | (if (and (not (string-null? str)) | |
1786 | (char-numeric? (string-ref str 0))) | |
1787 | (parse-non-negative-integer str) | |
1788 | (parse-date str))) | |
1789 | (lambda (val) | |
1790 | (or (date? val) (non-negative-integer? val))) | |
1791 | (lambda (val port) | |
1792 | (if (date? val) | |
1793 | (write-date val port) | |
1794 | (display val port)))) | |
1795 | ||
1796 | ;; Server = 1*( product | comment ) | |
1797 | ;; | |
be1be3e5 | 1798 | (declare-opaque-header! "Server") |
440840c1 AW |
1799 | |
1800 | ;; Vary = ( "*" | 1#field-name ) | |
1801 | ;; | |
be1be3e5 | 1802 | (declare-header! "Vary" |
440840c1 AW |
1803 | (lambda (str) |
1804 | (if (equal? str "*") | |
1805 | '* | |
adc91e41 | 1806 | (split-header-names str))) |
440840c1 | 1807 | (lambda (val) |
adc91e41 | 1808 | (or (eq? val '*) (list-of-header-names? val))) |
440840c1 AW |
1809 | (lambda (val port) |
1810 | (if (eq? val '*) | |
1811 | (display "*" port) | |
adc91e41 | 1812 | (write-header-list val port)))) |
440840c1 AW |
1813 | |
1814 | ;; WWW-Authenticate = 1#challenge | |
1815 | ;; | |
ecfb7167 | 1816 | (declare-challenge-list-header! "WWW-Authenticate") |
312e79f8 IP |
1817 | |
1818 | ||
1819 | ;; Chunked Responses | |
1820 | (define (read-chunk-header port) | |
1821 | (let* ((str (read-line port)) | |
1822 | (extension-start (string-index str (lambda (c) (or (char=? c #\;) | |
1823 | (char=? c #\return))))) | |
1824 | (size (string->number (if extension-start ; unnecessary? | |
1825 | (substring str 0 extension-start) | |
1826 | str) | |
1827 | 16))) | |
1828 | size)) | |
1829 | ||
1830 | (define (read-chunk port) | |
1831 | (let ((size (read-chunk-header port))) | |
1832 | (read-chunk-body port size))) | |
1833 | ||
1834 | (define (read-chunk-body port size) | |
1835 | (let ((bv (get-bytevector-n port size))) | |
1836 | (get-u8 port) ; CR | |
1837 | (get-u8 port) ; LF | |
1838 | bv)) | |
1839 | ||
1840 | (define* (make-chunked-input-port port #:key (keep-alive? #f)) | |
1841 | "Returns a new port which translates HTTP chunked transfer encoded | |
06883ae0 DH |
1842 | data from PORT into a non-encoded format. Returns eof when it has |
1843 | read the final chunk from PORT. This does not necessarily mean | |
1844 | that there is no more data on PORT. When the returned port is | |
1845 | closed it will also close PORT, unless the KEEP-ALIVE? is true." | |
312e79f8 IP |
1846 | (define (next-chunk) |
1847 | (read-chunk port)) | |
1848 | (define finished? #f) | |
1849 | (define (close) | |
1850 | (unless keep-alive? | |
1851 | (close-port port))) | |
1852 | (define buffer #vu8()) | |
1853 | (define buffer-size 0) | |
1854 | (define buffer-pointer 0) | |
1855 | (define (read! bv idx to-read) | |
1856 | (define (loop to-read num-read) | |
1857 | (cond ((or finished? (zero? to-read)) | |
1858 | num-read) | |
1859 | ((<= to-read (- buffer-size buffer-pointer)) | |
1860 | (bytevector-copy! buffer buffer-pointer | |
1861 | bv (+ idx num-read) | |
1862 | to-read) | |
1863 | (set! buffer-pointer (+ buffer-pointer to-read)) | |
1864 | (loop 0 (+ num-read to-read))) | |
1865 | (else | |
1866 | (let ((n (- buffer-size buffer-pointer))) | |
1867 | (bytevector-copy! buffer buffer-pointer | |
1868 | bv (+ idx num-read) | |
1869 | n) | |
1870 | (set! buffer (next-chunk)) | |
1871 | (set! buffer-pointer 0) | |
1872 | (set! buffer-size (bytevector-length buffer)) | |
1873 | (set! finished? (= buffer-size 0)) | |
1874 | (loop (- to-read n) | |
1875 | (+ num-read n)))))) | |
1876 | (loop to-read 0)) | |
1877 | (make-custom-binary-input-port "chunked input port" read! #f #f close)) | |
1878 | ||
1879 | (define* (make-chunked-output-port port #:key (keep-alive? #f)) | |
1880 | "Returns a new port which translates non-encoded data into a HTTP | |
06883ae0 | 1881 | chunked transfer encoded data and writes this to PORT. Data |
312e79f8 IP |
1882 | written to this port is buffered until the port is flushed, at which |
1883 | point it is all sent as one chunk. Take care to close the port when | |
1884 | done, as it will output the remaining data, and encode the final zero | |
06883ae0 | 1885 | chunk. When the port is closed it will also close PORT, unless |
312e79f8 IP |
1886 | KEEP-ALIVE? is true." |
1887 | (define (q-for-each f q) | |
1888 | (while (not (q-empty? q)) | |
1889 | (f (deq! q)))) | |
1890 | (define queue (make-q)) | |
1891 | (define (put-char c) | |
1892 | (enq! queue c)) | |
1893 | (define (put-string s) | |
1894 | (string-for-each (lambda (c) (enq! queue c)) | |
1895 | s)) | |
1896 | (define (flush) | |
1897 | ;; It is important that we do _not_ write a chunk if the queue is | |
1898 | ;; empty, since it will be treated as the final chunk. | |
1899 | (unless (q-empty? queue) | |
1900 | (let ((len (q-length queue))) | |
1901 | (display (number->string len 16) port) | |
1902 | (display "\r\n" port) | |
1903 | (q-for-each (lambda (elem) (write-char elem port)) | |
1904 | queue) | |
1905 | (display "\r\n" port)))) | |
1906 | (define (close) | |
1907 | (flush) | |
1908 | (display "0\r\n" port) | |
1909 | (force-output port) | |
1910 | (unless keep-alive? | |
1911 | (close-port port))) | |
1912 | (make-soft-port (vector put-char put-string flush #f close) "w")) |