3 ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
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.
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.
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
22 ;;; This module has a number of routines to parse textual
23 ;;; representations of HTTP data into native Scheme data structures.
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
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)
36 #:use-module (ice-9 regex)
37 #:use-module (ice-9 rdelim)
38 #:use-module (web uri)
39 #:export (string->header
68 ;;; Look at quality lists with more insight.
69 ;;; Think about `accept' a bit more.
73 (define (string->header name)
74 "Parse @var{name} to a symbolic header name."
75 (string->symbol (string-downcase name)))
77 (define-record-type <header-decl>
78 (make-header-decl name parser validator writer multiple?)
80 (name header-decl-name)
81 (parser header-decl-parser)
82 (validator header-decl-validator)
83 (writer header-decl-writer)
84 (multiple? header-decl-multiple?))
87 (define *declared-headers* (make-hash-table))
89 (define (lookup-header-decl sym)
90 (hashq-ref *declared-headers* sym))
92 (define* (declare-header! name
97 "Define a parser, validator, and writer for the HTTP header, @var{name}.
99 @var{parser} should be a procedure that takes a string and returns a
100 Scheme value. @var{validator} is a predicate for whether the given
101 Scheme value is valid for this header. @var{writer} takes a value and a
102 port, and writes the value to the port."
103 (if (and (string? name) parser validator writer)
104 (let ((decl (make-header-decl name parser validator writer multiple?)))
105 (hashq-set! *declared-headers* (string->header name) decl)
107 (error "bad header decl" name parser validator writer multiple?)))
109 (define (header->string sym)
110 "Return the string form for the header named @var{sym}."
111 (let ((decl (lookup-header-decl sym)))
113 (header-decl-name decl)
114 (string-titlecase (symbol->string sym)))))
116 (define (known-header? sym)
117 "Return @code{#t} if there are parsers and writers registered for this
118 header, otherwise @code{#f}."
119 (and (lookup-header-decl sym) #t))
121 (define (header-parser sym)
122 "Returns a procedure to parse values for the given header."
123 (let ((decl (lookup-header-decl sym)))
125 (header-decl-parser decl)
128 (define (header-validator sym)
129 "Returns a procedure to validate values for the given header."
130 (let ((decl (lookup-header-decl sym)))
132 (header-decl-validator decl)
135 (define (header-writer sym)
136 "Returns a procedure to write values for the given header to a given
138 (let ((decl (lookup-header-decl sym)))
140 (header-decl-writer decl)
143 (define (read-line* port)
144 (let* ((pair (%read-line port))
147 (if (and (string? line) (char? delim))
148 (let ((orig-len (string-length line)))
149 (let lp ((len orig-len))
151 (char-whitespace? (string-ref line (1- len))))
155 (substring line 0 len)))))
156 (bad-header '%read line))))
158 (define (read-continuation-line port val)
159 (if (or (eqv? (peek-char port) #\space)
160 (eqv? (peek-char port) #\tab))
161 (read-continuation-line port
167 (define *eof* (call-with-input-string "" read))
169 (define (read-header port)
170 "Reads one HTTP header from @var{port}. Returns two values: the header
171 name and the parsed Scheme value. May raise an exception if the header
172 was known but the value was invalid.
174 Returns the end-of-file object for both values if the end of the message
175 body was reached (i.e., a blank line)."
176 (let ((line (read-line* port)))
177 (if (or (string-null? line)
178 (string=? line "\r"))
180 (let* ((delim (or (string-index line #\:)
181 (bad-header '%read line)))
182 (sym (string->header (substring line 0 delim))))
187 (read-continuation-line
189 (string-trim-both line char-whitespace? (1+ delim)))))))))
191 (define (parse-header sym val)
192 "Parse @var{val}, a string, with the parser registered for the header
195 Returns the parsed value. If a parser was not found, the value is
196 returned as a string."
197 ((header-parser sym) val))
199 (define (valid-header? sym val)
200 "Returns a true value iff @var{val} is a valid Scheme value for the
201 header with name @var{sym}."
203 ((header-validator sym) val)
204 (error "header name not a symbol" sym)))
206 (define (write-header sym val port)
207 "Writes the given header name and value to @var{port}. If @var{sym}
208 is a known header, uses the specific writer registered for that header.
209 Otherwise the value is written using @var{display}."
210 (display (header->string sym) port)
212 ((header-writer sym) val port)
213 (display "\r\n" port))
215 (define (read-headers port)
216 "Read an HTTP message from @var{port}, returning the headers as an
218 (let lp ((headers '()))
219 (call-with-values (lambda () (read-header port))
223 (lp (acons k v headers)))))))
225 (define (write-headers headers port)
226 "Write the given header alist to @var{port}. Doesn't write the final
227 \\r\\n, as the user might want to add another header."
228 (let lp ((headers headers))
231 (write-header (caar headers) (cdar headers) port)
232 (lp (cdr headers))))))
241 (define (bad-header sym val)
242 (throw 'bad-header sym val))
243 (define (bad-header-component sym val)
244 (throw 'bad-header sym val))
246 (define (parse-opaque-string str)
248 (define (validate-opaque-string val)
250 (define (write-opaque-string val port)
253 (define separators-without-slash
254 (string->char-set "[^][()<>@,;:\\\"?= \t]"))
255 (define (validate-media-type str)
256 (let ((idx (string-index str #\/)))
257 (and idx (= idx (string-rindex str #\/))
258 (not (string-index str separators-without-slash)))))
259 (define (parse-media-type str)
260 (if (validate-media-type str)
262 (bad-header-component 'media-type str)))
264 (define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
266 (if (and (< i end) (char-whitespace? (string-ref str i)))
270 (define* (trim-whitespace str #:optional (start 0) (end (string-length str)))
272 (if (and (< start i) (char-whitespace? (string-ref str (1- i))))
276 (define* (split-and-trim str #:optional (delim #\,)
277 (start 0) (end (string-length str)))
280 (let* ((idx (string-index str delim i end))
281 (tok (string-trim-both str char-whitespace? i (or idx end))))
282 (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
285 (define (list-of-strings? val)
286 (list-of? val string?))
288 (define (write-list-of-strings val port)
289 (write-list val port display ", "))
291 (define (split-header-names str)
292 (map string->header (split-and-trim str)))
294 (define (list-of-header-names? val)
295 (list-of? val symbol?))
297 (define (write-header-list val port)
300 (display (header->string x) port))
303 (define (collect-escaped-string from start len escapes)
304 (let ((to (make-string len)))
305 (let lp ((start start) (i 0) (escapes escapes))
308 (substring-move! from start (+ start (- len i)) to i)
310 (let* ((e (car escapes))
311 (next-start (+ start (- e i) 2)))
312 (substring-move! from start (- next-start 2) to i)
313 (string-set! to e (string-ref from (- next-start 1)))
314 (lp next-start (1+ e) (cdr escapes)))))))
316 ;; in incremental mode, returns two values: the string, and the index at
317 ;; which the string ended
318 (define* (parse-qstring str #:optional
319 (start 0) (end (trim-whitespace str start))
321 (if (and (< start end) (eqv? (string-ref str start) #\"))
322 (let lp ((i (1+ start)) (qi 0) (escapes '()))
324 (case (string-ref str i)
326 (lp (+ i 2) (1+ qi) (cons qi escapes)))
328 (let ((out (collect-escaped-string str (1+ start) qi escapes)))
333 (bad-header-component 'qstring str)))))
335 (lp (1+ i) (1+ qi) escapes)))
336 (bad-header-component 'qstring str)))
337 (bad-header-component 'qstring str)))
339 (define (write-list l port write-item delim)
342 (write-item (car l) port)
348 (define (write-qstring str port)
350 (if (string-index str #\")
352 (write-list (string-split str #\") port display "\\\"")
356 (define* (parse-quality str #:optional (start 0) (end (string-length str)))
357 (define (char->decimal c)
358 (let ((i (- (char->integer c) (char->integer #\0))))
359 (if (and (<= 0 i) (< i 10))
361 (bad-header-component 'quality str))))
364 (bad-header-component 'quality str))
365 ((eqv? (string-ref str start) #\1)
366 (if (or (string= str "1" start end)
367 (string= str "1." start end)
368 (string= str "1.0" start end)
369 (string= str "1.00" start end)
370 (string= str "1.000" start end))
372 (bad-header-component 'quality str)))
373 ((eqv? (string-ref str start) #\0)
374 (if (or (string= str "0" start end)
375 (string= str "0." start end))
377 (if (< 2 (- end start) 6)
378 (let lp ((place 1) (i (+ start 4)) (q 0))
380 (if (eqv? (string-ref str (1+ start)) #\.)
382 (bad-header-component 'quality str))
383 (lp (* 10 place) (1- i)
385 (+ q (* place (char->decimal (string-ref str i))))
387 (bad-header-component 'quality str))))
388 ;; Allow the nonstandard .2 instead of 0.2.
389 ((and (eqv? (string-ref str start) #\.)
390 (< 1 (- end start) 5))
391 (let lp ((place 1) (i (+ start 3)) (q 0))
394 (lp (* 10 place) (1- i)
396 (+ q (* place (char->decimal (string-ref str i))))
399 (bad-header-component 'quality str))))
401 (define (valid-quality? q)
402 (and (non-negative-integer? q) (<= q 1000)))
404 (define (write-quality q port)
405 (define (digit->char d)
406 (integer->char (+ (char->integer #\0) d)))
407 (display (digit->char (modulo (quotient q 1000) 10)) port)
409 (display (digit->char (modulo (quotient q 100) 10)) port)
410 (display (digit->char (modulo (quotient q 10) 10)) port)
411 (display (digit->char (modulo q 10)) port))
413 (define (list-of? val pred)
417 (list-of? (cdr val) pred))))
419 (define* (parse-quality-list str)
422 ((string-rindex part #\;)
424 (let ((qpart (string-trim-both part char-whitespace? (1+ idx))))
425 (if (string-prefix? "q=" qpart)
426 (cons (parse-quality qpart 2)
427 (string-trim-both part char-whitespace? 0 idx))
428 (bad-header-component 'quality qpart)))))
430 (cons 1000 (string-trim-both part char-whitespace?)))))
431 (string-split str #\,)))
433 (define (validate-quality-list l)
437 (valid-quality? (car elt))
438 (string? (cdr elt))))))
440 (define (write-quality-list l port)
449 (write-quality q port)))))
452 (define* (parse-non-negative-integer val #:optional (start 0)
453 (end (string-length val)))
454 (define (char->decimal c)
455 (let ((i (- (char->integer c) (char->integer #\0))))
456 (if (and (<= 0 i) (< i 10))
458 (bad-header-component 'non-negative-integer val))))
459 (if (not (< start end))
460 (bad-header-component 'non-negative-integer val)
461 (let lp ((i start) (out 0))
464 (+ (* out 10) (char->decimal (string-ref val i))))
467 (define (non-negative-integer? code)
468 (and (number? code) (>= code 0) (exact? code) (integer? code)))
470 (define (default-kons k val)
475 (define (default-kv-validator k val)
478 (define (default-val-writer k val port)
479 (if (or (string-index val #\;)
480 (string-index val #\,)
481 (string-index val #\"))
482 (write-qstring val port)
485 (define* (parse-key-value-list str #:optional (kproc identity)
487 (start 0) (end (string-length str)))
488 (let lp ((i start) (out '()))
491 (let* ((i (skip-whitespace str i end))
492 (eq (string-index str #\= i end))
493 (comma (string-index str #\, i end))
494 (delim (min (or eq end) (or comma end)))
495 (k (kproc (substring str i (trim-whitespace str i delim)))))
498 (if (and eq (or (not comma) (< eq comma)))
499 (let ((i (skip-whitespace str (1+ eq) end)))
500 (if (and (< i end) (eqv? (string-ref str i) #\"))
501 (parse-qstring str i end #:incremental? #t)
502 (values (substring str i
503 (trim-whitespace str i
507 (lambda (v-str next-i)
508 (let ((i (skip-whitespace str next-i end)))
509 (if (or (= i end) (eqv? (string-ref str i) #\,))
510 (lp (1+ i) (cons (kons k v-str) out))
511 (bad-header-component 'key-value-list
512 (substring str start end))))))))))
514 (define* (key-value-list? list #:optional
515 (valid? default-kv-validator))
522 (and (or (string? k) (symbol? k))
524 ((or (string? elt) (symbol? elt))
528 (define* (write-key-value-list list port #:optional
529 (val-writer default-val-writer) (delim ", "))
533 (let ((k (if (pair? x) (car x) x))
534 (v (if (pair? x) (cdr x) #f)))
539 (val-writer k v port)))))
542 ;; param-component = token [ "=" (token | quoted-string) ] \
543 ;; *(";" token [ "=" (token | quoted-string) ])
545 (define* (parse-param-component str #:optional (kproc identity)
547 (start 0) (end (string-length str)))
548 (let lp ((i start) (out '()))
550 (values (reverse! out) end)
551 (let ((delim (string-index str
552 (lambda (c) (memq c '(#\, #\; #\=)))
555 (substring str i (trim-whitespace str i (or delim end)))))
556 (delimc (and delim (string-ref str delim))))
561 (let ((i (skip-whitespace str (1+ delim) end)))
562 (if (and (< i end) (eqv? (string-ref str i) #\"))
563 (parse-qstring str i end #:incremental? #t)
570 (char-whitespace? c)))
573 (values (substring str i delim)
575 (lambda (v-str next-i)
576 (let ((x (kons k v-str))
577 (i (skip-whitespace str next-i end)))
578 (case (and (< i end) (string-ref str i))
580 (values (reverse! (cons x out)) end))
582 (lp (skip-whitespace str (1+ i) end)
584 (else ; including #\,
585 (values (reverse! (cons x out)) i)))))))
587 (lp (skip-whitespace str (1+ delim) end)
588 (cons (kons k #f) out)))
590 (else ;; either the end of the string or a #\,
591 (values (reverse! (cons (kons k #f) out))
592 (or delim end)))))))))
594 (define* (parse-param-list str #:optional
595 (kproc identity) (kons default-kons)
596 (start 0) (end (string-length str)))
597 (let lp ((i start) (out '()))
599 (lambda () (parse-param-component str kproc kons i end))
602 (if (eqv? (string-ref str i) #\,)
603 (lp (skip-whitespace str (1+ i) end)
605 (bad-header-component 'param-list str))
606 (reverse! (cons item out)))))))
608 (define* (validate-param-list list #:optional
609 (valid? default-kv-validator))
612 (key-value-list? list valid?))))
614 (define* (write-param-list list port #:optional
615 (val-writer default-val-writer))
619 (write-key-value-list item port val-writer ";"))
622 (define (parse-date str)
623 ;; Unfortunately, there is no way to make string->date parse out the
624 ;; "GMT" bit, so we play string games to append a format it will
625 ;; understand (the +0000 bit).
627 (if (string-suffix? " GMT" str)
628 (string-append (substring str 0 (- (string-length str) 4))
630 (bad-header-component 'date str))
631 "~a, ~d ~b ~Y ~H:~M:~S ~z"))
633 (define (write-date date port)
634 (display (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT") port))
636 (define (write-uri uri port)
637 (display (uri->string uri) port))
639 (define (parse-entity-tag val)
640 (if (string-prefix? "W/" val)
641 (cons (parse-qstring val 2) #f)
642 (cons (parse-qstring val) #t)))
644 (define (entity-tag? val)
646 (string? (car val))))
648 (define (write-entity-tag val port)
651 (write-qstring (car val) port))
653 (define* (parse-entity-tag-list val #:optional
654 (start 0) (end (string-length val)))
655 (let ((strong? (not (string-prefix? "W/" val 0 2 start end))))
656 (call-with-values (lambda ()
657 (parse-qstring val (if strong? start (+ start 2))
658 end #:incremental? #t))
661 (let ((next (skip-whitespace val next end)))
663 (if (eqv? (string-ref val next) #\,)
664 (parse-entity-tag-list
666 (skip-whitespace val (1+ next) end)
668 (bad-header-component 'entity-tag-list val))
671 (define (entity-tag-list? val)
672 (list-of? val entity-tag?))
674 (define (write-entity-tag-list val port)
675 (write-list val port write-entity-tag ", "))
681 ;;; Request-Line and Response-Line
685 (define (bad-request message . args)
686 (throw 'bad-request message args))
687 (define (bad-response message . args)
688 (throw 'bad-response message args))
690 (define *known-versions* '())
692 (define* (parse-http-version str #:optional (start 0) (end (string-length str)))
693 "Parse an HTTP version from @var{str}, returning it as a major-minor
694 pair. For example, @code{HTTP/1.1} parses as the pair of integers,
696 (or (let lp ((known *known-versions*))
698 (if (string= str (caar known) start end)
701 (let ((dot-idx (string-index str #\. start end)))
702 (if (and (string-prefix? "HTTP/" str 0 5 start end)
704 (= dot-idx (string-rindex str #\. start end)))
705 (cons (parse-non-negative-integer str (+ start 5) dot-idx)
706 (parse-non-negative-integer str (1+ dot-idx) end))
707 (bad-header-component 'http-version (substring str start end))))))
709 (define (write-http-version val port)
710 "Write the given major-minor version pair to @var{port}."
711 (display "HTTP/" port)
712 (display (car val) port)
714 (display (cdr val) port))
718 (set! *known-versions*
719 (acons v (parse-http-version v 0 (string-length v))
721 '("HTTP/1.0" "HTTP/1.1"))
724 ;; Request-URI = "*" | absoluteURI | abs_path | authority
726 ;; The `authority' form is only permissible for the CONNECT method, so
727 ;; because we don't expect people to implement CONNECT, we save
728 ;; ourselves the trouble of that case, and disallow the CONNECT method.
730 (define* (parse-http-method str #:optional (start 0) (end (string-length str)))
731 "Parse an HTTP method from @var{str}. The result is an upper-case
732 symbol, like @code{GET}."
734 ((string= str "GET" start end) 'GET)
735 ((string= str "HEAD" start end) 'HEAD)
736 ((string= str "POST" start end) 'POST)
737 ((string= str "PUT" start end) 'PUT)
738 ((string= str "DELETE" start end) 'DELETE)
739 ((string= str "OPTIONS" start end) 'OPTIONS)
740 ((string= str "TRACE" start end) 'TRACE)
741 (else (bad-request "Invalid method: ~a" (substring str start end)))))
743 (define* (parse-request-uri str #:optional (start 0) (end (string-length str)))
744 "Parse a URI from an HTTP request line. Note that URIs in requests do
745 not have to have a scheme or host name. The result is a URI object."
748 (bad-request "Missing Request-URI"))
749 ((string= str "*" start end)
751 ((eq? (string-ref str start) #\/)
752 (let* ((q (string-index str #\? start end))
753 (f (string-index str #\# start end))
754 (q (and q (or (not f) (< q f)) q)))
756 #:path (substring str start (or q f end))
757 #:query (and q (substring str (1+ q) (or f end)))
758 #:fragment (and f (substring str (1+ f) end)))))
760 (or (string->uri (substring str start end))
761 (bad-request "Invalid URI: ~a" (substring str start end))))))
763 (define (read-request-line port)
764 "Read the first line of an HTTP request from @var{port}, returning
765 three values: the method, the URI, and the version."
766 (let* ((line (read-line* port))
767 (d0 (string-index line char-whitespace?)) ; "delimiter zero"
768 (d1 (string-rindex line char-whitespace?)))
769 (if (and d0 d1 (< d0 d1))
770 (values (parse-http-method line 0 d0)
771 (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
772 (parse-http-version line (1+ d1) (string-length line)))
773 (bad-request "Bad Request-Line: ~s" line))))
775 (define (write-uri uri port)
778 (display (uri-scheme uri) port)
780 (if (uri-userinfo uri)
782 (display (uri-userinfo uri) port)
784 (display (uri-host uri) port)
785 (let ((p (uri-port uri)))
786 (if (and p (not (eqv? p 80)))
789 (display p port))))))
790 (let* ((path (uri-path uri))
791 (len (string-length path)))
793 ((and (> len 0) (not (eqv? (string-ref path 0) #\/)))
794 (bad-request "Non-absolute URI path: ~s" path))
795 ((and (zero? len) (not (uri-host uri)))
796 (bad-request "Empty path and no host for URI: ~s" uri))
798 (display path port))))
802 (display (uri-query uri) port))))
804 (define (write-request-line method uri version port)
805 "Write the first line of an HTTP request to @var{port}."
806 (display method port)
807 (display #\space port)
809 (display #\space port)
810 (write-http-version version port)
811 (display "\r\n" port))
813 (define (read-response-line port)
814 "Read the first line of an HTTP response from @var{port}, returning
815 three values: the HTTP version, the response code, and the \"reason
817 (let* ((line (read-line* port))
818 (d0 (string-index line char-whitespace?)) ; "delimiter zero"
819 (d1 (and d0 (string-index line char-whitespace?
820 (skip-whitespace line d0)))))
822 (values (parse-http-version line 0 d0)
823 (parse-non-negative-integer line (skip-whitespace line d0 d1)
825 (string-trim-both line char-whitespace? d1))
826 (bad-response "Bad Response-Line: ~s" line))))
828 (define (write-response-line version code reason-phrase port)
829 "Write the first line of an HTTP response to @var{port}."
830 (write-http-version version port)
831 (display #\space port)
833 (display #\space port)
834 (display reason-phrase port)
835 (display "\r\n" port))
841 ;;; Helpers for declaring headers
844 ;; emacs: (put 'declare-header! 'scheme-indent-function 1)
845 ;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
846 (define (declare-opaque-header! name)
847 (declare-header! name
848 parse-opaque-string validate-opaque-string write-opaque-string))
850 ;; emacs: (put 'declare-date-header! 'scheme-indent-function 1)
851 (define (declare-date-header! name)
852 (declare-header! name
853 parse-date date? write-date))
855 ;; emacs: (put 'declare-string-list-header! 'scheme-indent-function 1)
856 (define (declare-string-list-header! name)
857 (declare-header! name
858 split-and-trim list-of-strings? write-list-of-strings))
860 ;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1)
861 (define (declare-header-list-header! name)
862 (declare-header! name
863 split-header-names list-of-header-names? write-header-list))
865 ;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1)
866 (define (declare-integer-header! name)
867 (declare-header! name
868 parse-non-negative-integer non-negative-integer? display))
870 ;; emacs: (put 'declare-uri-header! 'scheme-indent-function 1)
871 (define (declare-uri-header! name)
872 (declare-header! name
873 (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
877 ;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1)
878 (define (declare-quality-list-header! name)
879 (declare-header! name
880 parse-quality-list validate-quality-list write-quality-list))
882 ;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1)
883 (define* (declare-param-list-header! name #:optional
886 (val-validator default-kv-validator)
887 (val-writer default-val-writer))
888 (declare-header! name
889 (lambda (str) (parse-param-list str kproc kons))
890 (lambda (val) (validate-param-list val val-validator))
891 (lambda (val port) (write-param-list val port val-writer))))
893 ;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1)
894 (define* (declare-key-value-list-header! name #:optional
897 (val-validator default-kv-validator)
898 (val-writer default-val-writer))
899 (declare-header! name
900 (lambda (str) (parse-key-value-list str kproc kons))
901 (lambda (val) (key-value-list? val val-validator))
902 (lambda (val port) (write-key-value-list val port val-writer))))
904 ;; emacs: (put 'declare-entity-tag-list-header! 'scheme-indent-function 1)
905 (define (declare-entity-tag-list-header! name)
906 (declare-header! name
907 (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str)))
908 (lambda (val) (or (eq? val '*) (entity-tag-list? val)))
912 (write-entity-tag-list val port)))))
921 ;; Cache-Control = 1#(cache-directive)
922 ;; cache-directive = cache-request-directive | cache-response-directive
923 ;; cache-request-directive =
924 ;; "no-cache" ; Section 14.9.1
925 ;; | "no-store" ; Section 14.9.2
926 ;; | "max-age" "=" delta-seconds ; Section 14.9.3, 14.9.4
927 ;; | "max-stale" [ "=" delta-seconds ] ; Section 14.9.3
928 ;; | "min-fresh" "=" delta-seconds ; Section 14.9.3
929 ;; | "no-transform" ; Section 14.9.5
930 ;; | "only-if-cached" ; Section 14.9.4
931 ;; | cache-extension ; Section 14.9.6
932 ;; cache-response-directive =
933 ;; "public" ; Section 14.9.1
934 ;; | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1
935 ;; | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1
936 ;; | "no-store" ; Section 14.9.2
937 ;; | "no-transform" ; Section 14.9.5
938 ;; | "must-revalidate" ; Section 14.9.4
939 ;; | "proxy-revalidate" ; Section 14.9.4
940 ;; | "max-age" "=" delta-seconds ; Section 14.9.3
941 ;; | "s-maxage" "=" delta-seconds ; Section 14.9.3
942 ;; | cache-extension ; Section 14.9.6
943 ;; cache-extension = token [ "=" ( token | quoted-string ) ]
945 (declare-key-value-list-header! "Cache-Control"
946 (let ((known-directives (make-hash-table)))
947 (for-each (lambda (s)
948 (hash-set! known-directives s (string->symbol s)))
949 '("no-cache" "no-store" "max-age" "max-stale" "min-fresh"
950 "no-transform" "only-if-cached" "public" "private"
951 "must-revalidate" "proxy-revalidate" "s-maxage"))
953 (hash-ref known-directives k-str k-str)))
956 ((max-age max-stale min-fresh s-maxage)
957 (cons k (parse-non-negative-integer v-str)))
960 (cons k (split-header-names v-str))
962 (else (if v-str (cons k v-str) k))))
966 ((string? v) (display v port))
969 (write-header-list v port)
974 (bad-header-component 'cache-control v)))))
976 ;; Connection = "Connection" ":" 1#(connection-token)
977 ;; connection-token = token
979 ;; Connection: close, foo-header
981 (declare-string-list-header! "Connection")
983 ;; Date = "Date" ":" HTTP-date
985 ;; Date: Tue, 15 Nov 1994 08:12:31 GMT
987 (declare-date-header! "Date")
989 ;; Pragma = "Pragma" ":" 1#pragma-directive
990 ;; pragma-directive = "no-cache" | extension-pragma
991 ;; extension-pragma = token [ "=" ( token | quoted-string ) ]
993 (declare-key-value-list-header! "Pragma"
994 (lambda (k) (if (equal? k "no-cache") 'no-cache k)))
996 ;; Trailer = "Trailer" ":" 1#field-name
998 (declare-header-list-header! "Trailer")
1000 ;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding
1002 (declare-param-list-header! "Transfer-Encoding"
1004 (if (equal? k "chunked") 'chunked k)))
1006 ;; Upgrade = "Upgrade" ":" 1#product
1008 (declare-string-list-header! "Upgrade")
1010 ;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] )
1011 ;; received-protocol = [ protocol-name "/" ] protocol-version
1012 ;; protocol-name = token
1013 ;; protocol-version = token
1014 ;; received-by = ( host [ ":" port ] ) | pseudonym
1015 ;; pseudonym = token
1017 (declare-header! "Via"
1020 write-list-of-strings
1023 ;; Warning = "Warning" ":" 1#warning-value
1025 ;; warning-value = warn-code SP warn-agent SP warn-text
1028 ;; warn-code = 3DIGIT
1029 ;; warn-agent = ( host [ ":" port ] ) | pseudonym
1030 ;; ; the name or pseudonym of the server adding
1031 ;; ; the Warning header, for use in debugging
1032 ;; warn-text = quoted-string
1033 ;; warn-date = <"> HTTP-date <">
1034 (declare-header! "Warning"
1036 (let ((len (string-length str)))
1037 (let lp ((i (skip-whitespace str 0)))
1038 (let* ((idx1 (string-index str #\space i))
1039 (idx2 (string-index str #\space (1+ idx1))))
1041 (let ((code (parse-non-negative-integer str i idx1))
1042 (agent (substring str (1+ idx1) idx2)))
1044 (lambda () (parse-qstring str (1+ idx2) #:incremental? #t))
1048 (let ((c (and (< i len) (string-ref str i))))
1053 (lambda () (parse-qstring str (1+ i)
1056 (values text (parse-date date) i))))
1058 (values text #f i)))))
1059 (lambda (text date i)
1060 (let ((w (list code agent text date))
1061 (c (and (< i len) (string-ref str i))))
1064 ((#\,) (cons w (lp (skip-whitespace str (1+ i)))))
1065 (else (bad-header 'warning str))))))))))))))
1071 (apply (lambda (code host text date)
1072 (and (non-negative-integer? code) (< code 1000)
1075 (or (not date) (date? date))))
1082 (lambda (code host text date)
1084 (display #\space port)
1086 (display #\space port)
1087 (write-qstring text port)
1090 (display #\space port)
1091 (write-date date port))))
1105 (declare-string-list-header! "Allow")
1107 ;; Content-Encoding = 1#content-coding
1109 (declare-string-list-header! "Content-Encoding")
1111 ;; Content-Language = 1#language-tag
1113 (declare-string-list-header! "Content-Language")
1115 ;; Content-Length = 1*DIGIT
1117 (declare-integer-header! "Content-Length")
1119 ;; Content-Location = ( absoluteURI | relativeURI )
1121 (declare-uri-header! "Content-Location")
1123 ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
1125 (declare-opaque-header! "Content-MD5")
1127 ;; Content-Range = content-range-spec
1128 ;; content-range-spec = byte-content-range-spec
1129 ;; byte-content-range-spec = bytes-unit SP
1130 ;; byte-range-resp-spec "/"
1131 ;; ( instance-length | "*" )
1132 ;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos)
1134 ;; instance-length = 1*DIGIT
1136 (declare-header! "Content-Range"
1138 (let ((dash (string-index str #\-))
1139 (slash (string-index str #\/)))
1140 (if (and (string-prefix? "bytes " str) slash)
1145 (parse-non-negative-integer str 6 dash)
1146 (parse-non-negative-integer str (1+ dash) slash)))
1147 ((string= str "*" 6 slash)
1150 (bad-header 'content-range str)))
1151 (if (string= str "*" (1+ slash))
1153 (parse-non-negative-integer str (1+ slash))))
1154 (bad-header 'content-range str))))
1156 (and (list? val) (= (length val) 3)
1158 (let ((x (cadr val)))
1161 (non-negative-integer? (car x))
1162 (non-negative-integer? (cdr x)))))
1163 (let ((x (caddr val)))
1165 (non-negative-integer? x)))))
1167 (display (car val) port)
1168 (display #\space port)
1169 (if (eq? (cadr val) '*)
1172 (display (caadr val) port)
1174 (display (caadr val) port)))
1175 (if (eq? (caddr val) '*)
1177 (display (caddr val) port))))
1179 ;; Content-Type = media-type
1181 (declare-header! "Content-Type"
1183 (let ((parts (string-split str #\;)))
1184 (cons (parse-media-type (car parts))
1186 (let ((eq (string-index x #\=)))
1187 (if (and eq (= eq (string-rindex x #\=)))
1188 (cons (string-trim x char-whitespace? 0 eq)
1189 (string-trim-right x char-whitespace? (1+ eq)))
1190 (bad-header 'content-type str))))
1197 (and (pair? x) (string? (car x)) (string? (cdr x)))))))
1199 (display (car val) port)
1200 (if (pair? (cdr val))
1206 (display (car pair) port)
1208 (display (cdr pair) port))
1211 ;; Expires = HTTP-date
1213 (declare-date-header! "Expires")
1215 ;; Last-Modified = HTTP-date
1217 (declare-date-header! "Last-Modified")
1226 ;; Accept = #( media-range [ accept-params ] )
1227 ;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) )
1228 ;; *( ";" parameter )
1229 ;; accept-params = ";" "q" "=" qvalue *( accept-extension )
1230 ;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
1232 (declare-param-list-header! "Accept"
1233 ;; -> ("type/subtype" (str-prop . str-val) ...) ...)
1235 ;; with the exception of prop = "q", in which case the prop will be
1236 ;; the symbol 'q, and the val will be a valid quality value
1238 (lambda (k) (if (string=? k "q") 'q k))
1241 (cons k (parse-quality v))
1242 (default-kons k v)))
1246 (default-kv-validator k v)))
1249 (write-quality v port)
1250 (default-val-writer k v port))))
1252 ;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] )
1254 (declare-quality-list-header! "Accept-Charset")
1256 ;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] )
1257 ;; codings = ( content-coding | "*" )
1259 (declare-quality-list-header! "Accept-Encoding")
1261 ;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] )
1262 ;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )
1264 (declare-quality-list-header! "Accept-Language")
1266 ;; Authorization = credentials
1268 ;; Authorization is basically opaque to this HTTP stack, we just pass
1269 ;; the string value through.
1271 (declare-opaque-header! "Authorization")
1273 ;; Expect = 1#expectation
1274 ;; expectation = "100-continue" | expectation-extension
1275 ;; expectation-extension = token [ "=" ( token | quoted-string )
1277 ;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
1279 (declare-param-list-header! "Expect"
1281 (if (equal? k "100-continue")
1287 ;; Should be an email address; we just pass on the string as-is.
1289 (declare-opaque-header! "From")
1291 ;; Host = host [ ":" port ]
1293 (declare-header! "Host"
1295 (let ((colon (string-index str #\:)))
1297 (cons (substring str 0 colon)
1298 (parse-non-negative-integer str (1+ colon)))
1304 (non-negative-integer? (cdr val)))))
1306 (display (car val) port)
1310 (display (cdr val) port)))))
1312 ;; If-Match = ( "*" | 1#entity-tag )
1314 (declare-entity-tag-list-header! "If-Match")
1316 ;; If-Modified-Since = HTTP-date
1318 (declare-date-header! "If-Modified-Since")
1320 ;; If-None-Match = ( "*" | 1#entity-tag )
1322 (declare-entity-tag-list-header! "If-None-Match")
1324 ;; If-Range = ( entity-tag | HTTP-date )
1326 (declare-header! "If-Range"
1328 (if (or (string-prefix? "\"" str)
1329 (string-prefix? "W/" str))
1330 (parse-entity-tag str)
1333 (or (date? val) (entity-tag? val)))
1336 (write-date val port)
1337 (write-entity-tag val port))))
1339 ;; If-Unmodified-Since = HTTP-date
1341 (declare-date-header! "If-Unmodified-Since")
1343 ;; Max-Forwards = 1*DIGIT
1345 (declare-integer-header! "Max-Forwards")
1347 ;; Proxy-Authorization = credentials
1349 (declare-opaque-header! "Proxy-Authorization")
1351 ;; Range = "Range" ":" ranges-specifier
1352 ;; ranges-specifier = byte-ranges-specifier
1353 ;; byte-ranges-specifier = bytes-unit "=" byte-range-set
1354 ;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec )
1355 ;; byte-range-spec = first-byte-pos "-" [last-byte-pos]
1356 ;; first-byte-pos = 1*DIGIT
1357 ;; last-byte-pos = 1*DIGIT
1358 ;; suffix-byte-range-spec = "-" suffix-length
1359 ;; suffix-length = 1*DIGIT
1361 (declare-header! "Range"
1363 (if (string-prefix? "bytes=" str)
1367 (let ((dash (string-index x #\-)))
1370 (bad-header 'range str))
1372 (cons #f (parse-non-negative-integer x 1)))
1373 ((= dash (1- (string-length x)))
1374 (cons (parse-non-negative-integer x 0 dash) #f))
1376 (cons (parse-non-negative-integer x 0 dash)
1377 (parse-non-negative-integer x (1+ dash)))))))
1378 (string-split (substring str 6) #\,)))
1379 (bad-header 'range str)))
1386 (let ((x (car elt)) (y (cdr elt)))
1388 (or (not x) (non-negative-integer? x))
1389 (or (not y) (non-negative-integer? y)))))))))
1391 (display (car val) port)
1397 (display (car pair) port))
1400 (display (cdr pair) port)))
1403 ;; Referer = ( absoluteURI | relativeURI )
1405 (declare-uri-header! "Referer")
1407 ;; TE = #( t-codings )
1408 ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
1410 (declare-param-list-header! "TE"
1411 (lambda (k) (if (equal? k "trailers") 'trailers k)))
1413 ;; User-Agent = 1*( product | comment )
1415 (declare-opaque-header! "User-Agent")
1424 ;; Accept-Ranges = acceptable-ranges
1425 ;; acceptable-ranges = 1#range-unit | "none"
1427 (declare-string-list-header! "Accept-Ranges")
1430 ;; age-value = delta-seconds
1432 (declare-integer-header! "Age")
1434 ;; ETag = entity-tag
1436 (declare-header! "ETag"
1441 ;; Location = absoluteURI
1443 (declare-uri-header! "Location")
1445 ;; Proxy-Authenticate = 1#challenge
1447 ;; FIXME: split challenges ?
1448 (declare-opaque-header! "Proxy-Authenticate")
1450 ;; Retry-After = ( HTTP-date | delta-seconds )
1452 (declare-header! "Retry-After"
1454 (if (and (not (string-null? str))
1455 (char-numeric? (string-ref str 0)))
1456 (parse-non-negative-integer str)
1459 (or (date? val) (non-negative-integer? val)))
1462 (write-date val port)
1463 (display val port))))
1465 ;; Server = 1*( product | comment )
1467 (declare-opaque-header! "Server")
1469 ;; Vary = ( "*" | 1#field-name )
1471 (declare-header! "Vary"
1473 (if (equal? str "*")
1475 (split-header-names str)))
1477 (or (eq? val '*) (list-of-header-names? val)))
1481 (write-header-list val port))))
1483 ;; WWW-Authenticate = 1#challenge
1486 (declare-opaque-header! "WWW-Authenticate")