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