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