3 ;; Copyright (C) 2010, 2011, 2012 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 rdelim)
37 #:use-module (ice-9 q)
38 #:use-module (ice-9 binary-ports)
39 #:use-module (rnrs bytevectors)
40 #:use-module (web uri)
41 #:export (string->header
45 declare-opaque-header!
68 make-chunked-input-port
69 make-chunked-output-port))
74 ;;; Look at quality lists with more insight.
75 ;;; Think about `accept' a bit more.
79 (define (string->header name)
80 "Parse @var{name} to a symbolic header name."
81 (string->symbol (string-downcase name)))
83 (define-record-type <header-decl>
84 (make-header-decl name parser validator writer multiple?)
86 (name header-decl-name)
87 (parser header-decl-parser)
88 (validator header-decl-validator)
89 (writer header-decl-writer)
90 (multiple? header-decl-multiple?))
93 (define *declared-headers* (make-hash-table))
95 (define (lookup-header-decl sym)
96 (hashq-ref *declared-headers* sym))
98 (define* (declare-header! name
103 "Define a parser, validator, and writer for the HTTP header, @var{name}.
105 @var{parser} should be a procedure that takes a string and returns a
106 Scheme value. @var{validator} is a predicate for whether the given
107 Scheme value is valid for this header. @var{writer} takes a value and a
108 port, and writes the value to the port."
109 (if (and (string? name) parser validator writer)
110 (let ((decl (make-header-decl name parser validator writer multiple?)))
111 (hashq-set! *declared-headers* (string->header name) decl)
113 (error "bad header decl" name parser validator writer multiple?)))
115 (define (header->string sym)
116 "Return the string form for the header named @var{sym}."
117 (let ((decl (lookup-header-decl sym)))
119 (header-decl-name decl)
120 (string-titlecase (symbol->string sym)))))
122 (define (known-header? sym)
123 "Return @code{#t} if there are parsers and writers registered for this
124 header, otherwise @code{#f}."
125 (and (lookup-header-decl sym) #t))
127 (define (header-parser sym)
128 "Returns a procedure to parse values for the given header."
129 (let ((decl (lookup-header-decl sym)))
131 (header-decl-parser decl)
134 (define (header-validator sym)
135 "Returns a procedure to validate values for the given header."
136 (let ((decl (lookup-header-decl sym)))
138 (header-decl-validator decl)
141 (define (header-writer sym)
142 "Returns a procedure to write values for the given header to a given
144 (let ((decl (lookup-header-decl sym)))
146 (header-decl-writer decl)
149 (define (read-line* port)
150 (let* ((pair (%read-line port))
153 (if (and (string? line) (char? delim))
154 (let ((orig-len (string-length line)))
155 (let lp ((len orig-len))
157 (char-whitespace? (string-ref line (1- len))))
161 (substring line 0 len)))))
162 (bad-header '%read line))))
164 (define (read-continuation-line port val)
165 (if (or (eqv? (peek-char port) #\space)
166 (eqv? (peek-char port) #\tab))
167 (read-continuation-line port
173 (define *eof* (call-with-input-string "" read))
175 (define (read-header port)
176 "Reads one HTTP header from @var{port}. Returns two values: the header
177 name and the parsed Scheme value. May raise an exception if the header
178 was known but the value was invalid.
180 Returns the end-of-file object for both values if the end of the message
181 body was reached (i.e., a blank line)."
182 (let ((line (read-line* port)))
183 (if (or (string-null? line)
184 (string=? line "\r"))
186 (let* ((delim (or (string-index line #\:)
187 (bad-header '%read line)))
188 (sym (string->header (substring line 0 delim))))
193 (read-continuation-line
195 (string-trim-both line char-set:whitespace (1+ delim)))))))))
197 (define (parse-header sym val)
198 "Parse @var{val}, a string, with the parser registered for the header
201 Returns the parsed value. If a parser was not found, the value is
202 returned as a string."
203 ((header-parser sym) val))
205 (define (valid-header? sym val)
206 "Returns a true value iff @var{val} is a valid Scheme value for the
207 header with name @var{sym}."
209 ((header-validator sym) val)
210 (error "header name not a symbol" sym)))
212 (define (write-header sym val port)
213 "Writes the given header name and value to @var{port}. If @var{sym}
214 is a known header, uses the specific writer registered for that header.
215 Otherwise the value is written using @code{display}."
216 (display (header->string sym) port)
218 ((header-writer sym) val port)
219 (display "\r\n" port))
221 (define (read-headers port)
222 "Read an HTTP message from @var{port}, returning the headers as an
224 (let lp ((headers '()))
225 (call-with-values (lambda () (read-header port))
229 (lp (acons k v headers)))))))
231 (define (write-headers headers port)
232 "Write the given header alist to @var{port}. Doesn't write the final
233 \\r\\n, as the user might want to add another header."
234 (let lp ((headers headers))
237 (write-header (caar headers) (cdar headers) port)
238 (lp (cdr headers))))))
247 (define (bad-header sym val)
248 (throw 'bad-header sym val))
249 (define (bad-header-component sym val)
250 (throw 'bad-header-component sym val))
252 (define (bad-header-printer port key args default-printer)
255 (format port "Bad ~a header: ~a\n" (header->string sym) val))
256 (_ (default-printer)))
258 (define (bad-header-component-printer port key args default-printer)
261 (format port "Bad ~a header component: ~a\n" sym val))
262 (_ (default-printer)))
264 (set-exception-printer! 'bad-header bad-header-printer)
265 (set-exception-printer! 'bad-header-component bad-header-component-printer)
267 (define (parse-opaque-string str)
269 (define (validate-opaque-string val)
271 (define (write-opaque-string val port)
274 (define separators-without-slash
275 (string->char-set "[^][()<>@,;:\\\"?= \t]"))
276 (define (validate-media-type str)
277 (let ((idx (string-index str #\/)))
278 (and idx (= idx (string-rindex str #\/))
279 (not (string-index str separators-without-slash)))))
280 (define (parse-media-type str)
281 (if (validate-media-type str)
283 (bad-header-component 'media-type str)))
285 (define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
287 (if (and (< i end) (char-whitespace? (string-ref str i)))
291 (define* (trim-whitespace str #:optional (start 0) (end (string-length str)))
293 (if (and (< start i) (char-whitespace? (string-ref str (1- i))))
297 (define* (split-and-trim str #:optional (delim #\,)
298 (start 0) (end (string-length str)))
301 (let* ((idx (string-index str delim i end))
302 (tok (string-trim-both str char-set:whitespace i (or idx end))))
303 (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
306 (define (list-of-strings? val)
307 (list-of? val string?))
309 (define (write-list-of-strings val port)
310 (write-list val port display ", "))
312 (define (split-header-names str)
313 (map string->header (split-and-trim str)))
315 (define (list-of-header-names? val)
316 (list-of? val symbol?))
318 (define (write-header-list val port)
321 (display (header->string x) port))
324 (define (collect-escaped-string from start len escapes)
325 (let ((to (make-string len)))
326 (let lp ((start start) (i 0) (escapes escapes))
329 (substring-move! from start (+ start (- len i)) to i)
331 (let* ((e (car escapes))
332 (next-start (+ start (- e i) 2)))
333 (substring-move! from start (- next-start 2) to i)
334 (string-set! to e (string-ref from (- next-start 1)))
335 (lp next-start (1+ e) (cdr escapes)))))))
337 ;; in incremental mode, returns two values: the string, and the index at
338 ;; which the string ended
339 (define* (parse-qstring str #:optional
340 (start 0) (end (trim-whitespace str start))
342 (if (and (< start end) (eqv? (string-ref str start) #\"))
343 (let lp ((i (1+ start)) (qi 0) (escapes '()))
345 (case (string-ref str i)
347 (lp (+ i 2) (1+ qi) (cons qi escapes)))
349 (let ((out (collect-escaped-string str (1+ start) qi escapes)))
354 (bad-header-component 'qstring str)))))
356 (lp (1+ i) (1+ qi) escapes)))
357 (bad-header-component 'qstring str)))
358 (bad-header-component 'qstring str)))
360 (define (write-list l port write-item delim)
363 (write-item (car l) port)
369 (define (write-qstring str port)
371 (if (string-index str #\")
373 (write-list (string-split str #\") port display "\\\"")
377 (define* (parse-quality str #:optional (start 0) (end (string-length str)))
378 (define (char->decimal c)
379 (let ((i (- (char->integer c) (char->integer #\0))))
380 (if (and (<= 0 i) (< i 10))
382 (bad-header-component 'quality str))))
385 (bad-header-component 'quality str))
386 ((eqv? (string-ref str start) #\1)
387 (if (or (string= str "1" start end)
388 (string= str "1." start end)
389 (string= str "1.0" start end)
390 (string= str "1.00" start end)
391 (string= str "1.000" start end))
393 (bad-header-component 'quality str)))
394 ((eqv? (string-ref str start) #\0)
395 (if (or (string= str "0" start end)
396 (string= str "0." start end))
398 (if (< 2 (- end start) 6)
399 (let lp ((place 1) (i (+ start 4)) (q 0))
401 (if (eqv? (string-ref str (1+ start)) #\.)
403 (bad-header-component 'quality str))
404 (lp (* 10 place) (1- i)
406 (+ q (* place (char->decimal (string-ref str i))))
408 (bad-header-component 'quality str))))
409 ;; Allow the nonstandard .2 instead of 0.2.
410 ((and (eqv? (string-ref str start) #\.)
411 (< 1 (- end start) 5))
412 (let lp ((place 1) (i (+ start 3)) (q 0))
415 (lp (* 10 place) (1- i)
417 (+ q (* place (char->decimal (string-ref str i))))
420 (bad-header-component 'quality str))))
422 (define (valid-quality? q)
423 (and (non-negative-integer? q) (<= q 1000)))
425 (define (write-quality q port)
426 (define (digit->char d)
427 (integer->char (+ (char->integer #\0) d)))
428 (display (digit->char (modulo (quotient q 1000) 10)) port)
430 (display (digit->char (modulo (quotient q 100) 10)) port)
431 (display (digit->char (modulo (quotient q 10) 10)) port)
432 (display (digit->char (modulo q 10)) port))
434 (define (list-of? val pred)
438 (list-of? (cdr val) pred))))
440 (define* (parse-quality-list str)
443 ((string-rindex part #\;)
445 (let ((qpart (string-trim-both part char-set:whitespace (1+ idx))))
446 (if (string-prefix? "q=" qpart)
447 (cons (parse-quality qpart 2)
448 (string-trim-both part char-set:whitespace 0 idx))
449 (bad-header-component 'quality qpart)))))
451 (cons 1000 (string-trim-both part char-set:whitespace)))))
452 (string-split str #\,)))
454 (define (validate-quality-list l)
458 (valid-quality? (car elt))
459 (string? (cdr elt))))))
461 (define (write-quality-list l port)
470 (write-quality q port)))))
473 (define* (parse-non-negative-integer val #:optional (start 0)
474 (end (string-length val)))
475 (define (char->decimal c)
476 (let ((i (- (char->integer c) (char->integer #\0))))
477 (if (and (<= 0 i) (< i 10))
479 (bad-header-component 'non-negative-integer val))))
480 (if (not (< start end))
481 (bad-header-component 'non-negative-integer val)
482 (let lp ((i start) (out 0))
485 (+ (* out 10) (char->decimal (string-ref val i))))
488 (define (non-negative-integer? code)
489 (and (number? code) (>= code 0) (exact? code) (integer? code)))
491 (define (default-val-parser k val)
494 (define (default-val-validator k val)
495 (or (not val) (string? val)))
497 (define (default-val-writer k val port)
498 (if (or (string-index val #\;)
499 (string-index val #\,)
500 (string-index val #\"))
501 (write-qstring val port)
504 (define* (parse-key-value-list str #:optional
505 (val-parser default-val-parser)
506 (start 0) (end (string-length str)))
507 (let lp ((i start) (out '()))
510 (let* ((i (skip-whitespace str i end))
511 (eq (string-index str #\= i end))
512 (comma (string-index str #\, i end))
513 (delim (min (or eq end) (or comma end)))
515 (substring str i (trim-whitespace str i delim)))))
518 (if (and eq (or (not comma) (< eq comma)))
519 (let ((i (skip-whitespace str (1+ eq) end)))
520 (if (and (< i end) (eqv? (string-ref str i) #\"))
521 (parse-qstring str i end #:incremental? #t)
522 (values (substring str i
523 (trim-whitespace str i
527 (lambda (v-str next-i)
528 (let ((v (val-parser k v-str))
529 (i (skip-whitespace str next-i end)))
530 (if (or (= i end) (eqv? (string-ref str i) #\,))
531 (lp (1+ i) (cons (if v (cons k v) k) out))
532 (bad-header-component 'key-value-list
533 (substring str start end))))))))))
535 (define* (key-value-list? list #:optional
536 (valid? default-val-validator))
549 (define* (write-key-value-list list port #:optional
550 (val-writer default-val-writer) (delim ", "))
554 (let ((k (if (pair? x) (car x) x))
555 (v (if (pair? x) (cdr x) #f)))
560 (val-writer k v port)))))
563 ;; param-component = token [ "=" (token | quoted-string) ] \
564 ;; *(";" token [ "=" (token | quoted-string) ])
566 (define param-delimiters (char-set #\, #\; #\=))
567 (define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;))
568 (define* (parse-param-component str #:optional
569 (val-parser default-val-parser)
570 (start 0) (end (string-length str)))
571 (let lp ((i start) (out '()))
573 (values (reverse! out) end)
574 (let ((delim (string-index str param-delimiters i)))
575 (let ((k (string->symbol
576 (substring str i (trim-whitespace str i (or delim end)))))
577 (delimc (and delim (string-ref str delim))))
582 (let ((i (skip-whitespace str (1+ delim) end)))
583 (if (and (< i end) (eqv? (string-ref str i) #\"))
584 (parse-qstring str i end #:incremental? #t)
586 (or (string-index str param-value-delimiters
589 (values (substring str i delim)
591 (lambda (v-str next-i)
592 (let* ((v (val-parser k v-str))
593 (x (if v (cons k v) k))
594 (i (skip-whitespace str next-i end)))
595 (case (and (< i end) (string-ref str i))
597 (values (reverse! (cons x out)) end))
599 (lp (skip-whitespace str (1+ i) end)
601 (else ; including #\,
602 (values (reverse! (cons x out)) i)))))))
604 (let ((v (val-parser k #f)))
605 (lp (skip-whitespace str (1+ delim) end)
606 (cons (if v (cons k v) k) out))))
608 (else ;; either the end of the string or a #\,
609 (let ((v (val-parser k #f)))
610 (values (reverse! (cons (if v (cons k v) k) out))
611 (or delim end))))))))))
613 (define* (parse-param-list str #:optional
614 (val-parser default-val-parser)
615 (start 0) (end (string-length str)))
616 (let lp ((i start) (out '()))
618 (lambda () (parse-param-component str val-parser i end))
621 (if (eqv? (string-ref str i) #\,)
622 (lp (skip-whitespace str (1+ i) end)
624 (bad-header-component 'param-list str))
625 (reverse! (cons item out)))))))
627 (define* (validate-param-list list #:optional
628 (valid? default-val-validator))
631 (key-value-list? elt valid?))))
633 (define* (write-param-list list port #:optional
634 (val-writer default-val-writer))
638 (write-key-value-list item port val-writer ";"))
641 (define-syntax string-match?
644 ((_ str pat) (string? (syntax->datum #'pat))
645 (let ((p (syntax->datum #'pat)))
648 (= (string-length s) #,(string-length p))
649 #,@(let lp ((i 0) (tests '()))
650 (if (< i (string-length p))
651 (let ((c (string-ref p i)))
657 (cons #`(char-numeric? (string-ref s #,i))
660 (cons #`(char-alphabetic? (string-ref s #,i))
663 (cons #`(eqv? (string-ref s #,i) #,c)
667 ;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun"
668 ;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"
670 (define (parse-month str start end)
672 (bad-header-component 'month (substring str start end)))
673 (if (not (= (- end start) 3))
675 (let ((a (string-ref str (+ start 0)))
676 (b (string-ref str (+ start 1)))
677 (c (string-ref str (+ start 2))))
681 ((#\a) (case c ((#\n) 1) (else (bad))))
682 ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad))))
686 ((#\e) (case c ((#\b) 2) (else (bad))))
690 ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad))))
694 ((#\p) (case c ((#\r) 4) (else (bad))))
695 ((#\u) (case c ((#\g) 8) (else (bad))))
699 ((#\e) (case c ((#\p) 9) (else (bad))))
703 ((#\c) (case c ((#\t) 10) (else (bad))))
707 ((#\o) (case c ((#\v) 11) (else (bad))))
711 ((#\e) (case c ((#\c) 12) (else (bad))))
715 ;; RFC 822, updated by RFC 1123
717 ;; Sun, 06 Nov 1994 08:49:37 GMT
718 ;; 01234567890123456789012345678
720 (define (parse-rfc-822-date str)
721 ;; We could verify the day of the week but we don't.
722 (cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT")
723 (let ((date (parse-non-negative-integer str 5 7))
724 (month (parse-month str 8 11))
725 (year (parse-non-negative-integer str 12 16))
726 (hour (parse-non-negative-integer str 17 19))
727 (minute (parse-non-negative-integer str 20 22))
728 (second (parse-non-negative-integer str 23 25)))
729 (make-date 0 second minute hour date month year 0)))
730 ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT")
731 (let ((date (parse-non-negative-integer str 5 6))
732 (month (parse-month str 7 10))
733 (year (parse-non-negative-integer str 11 15))
734 (hour (parse-non-negative-integer str 16 18))
735 (minute (parse-non-negative-integer str 19 21))
736 (second (parse-non-negative-integer str 22 24)))
737 (make-date 0 second minute hour date month year 0)))
739 (bad-header 'date str) ; prevent tail call
742 ;; RFC 850, updated by RFC 1036
743 ;; Sunday, 06-Nov-94 08:49:37 GMT
744 ;; 0123456789012345678901
746 (define (parse-rfc-850-date str comma)
747 ;; We could verify the day of the week but we don't.
748 (let ((tail (substring str (1+ comma))))
749 (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT"))
750 (bad-header 'date str))
751 (let ((date (parse-non-negative-integer tail 1 3))
752 (month (parse-month tail 4 7))
753 (year (parse-non-negative-integer tail 8 10))
754 (hour (parse-non-negative-integer tail 11 13))
755 (minute (parse-non-negative-integer tail 14 16))
756 (second (parse-non-negative-integer tail 17 19)))
757 (make-date 0 second minute hour date month
758 (let* ((now (date-year (current-date)))
759 (then (+ now year (- (modulo now 100)))))
760 (cond ((< (+ then 50) now) (+ then 100))
761 ((< (+ now 50) then) (- then 100))
765 ;; ANSI C's asctime() format
766 ;; Sun Nov 6 08:49:37 1994
767 ;; 012345678901234567890123
769 (define (parse-asctime-date str)
770 (if (not (string-match? str "aaa aaa .d dd:dd:dd dddd"))
771 (bad-header 'date str))
772 (let ((date (parse-non-negative-integer
774 (if (eqv? (string-ref str 8) #\space) 9 8)
776 (month (parse-month str 4 7))
777 (year (parse-non-negative-integer str 20 24))
778 (hour (parse-non-negative-integer str 11 13))
779 (minute (parse-non-negative-integer str 14 16))
780 (second (parse-non-negative-integer str 17 19)))
781 (make-date 0 second minute hour date month year 0)))
783 (define (parse-date str)
784 (if (string-suffix? " GMT" str)
785 (let ((comma (string-index str #\,)))
786 (cond ((not comma) (bad-header 'date str))
787 ((= comma 3) (parse-rfc-822-date str))
788 (else (parse-rfc-850-date str comma))))
789 (parse-asctime-date str)))
791 (define (write-date date port)
792 (define (display-digits n digits port)
793 (define zero (char->integer #\0))
794 (let lp ((tens (expt 10 (1- digits))))
797 (display (integer->char (+ zero (modulo (truncate/ n tens) 10)))
799 (lp (floor/ tens 10))))))
800 (let ((date (if (zero? (date-zone-offset date))
802 (time-tai->date (date->time-tai date) 0))))
803 (display (case (date-week-day date)
804 ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ")
805 ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ")
806 ((6) "Sat, ") (else (error "bad date" date)))
808 (display-digits (date-day date) 2 port)
809 (display (case (date-month date)
810 ((1) " Jan ") ((2) " Feb ") ((3) " Mar ")
811 ((4) " Apr ") ((5) " May ") ((6) " Jun ")
812 ((7) " Jul ") ((8) " Aug ") ((9) " Sep ")
813 ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
814 (else (error "bad date" date)))
816 (display-digits (date-year date) 4 port)
817 (display #\space port)
818 (display-digits (date-hour date) 2 port)
820 (display-digits (date-minute date) 2 port)
822 (display-digits (date-second date) 2 port)
823 (display " GMT" port)))
825 (define (parse-entity-tag val)
826 (if (string-prefix? "W/" val)
827 (cons (parse-qstring val 2) #f)
828 (cons (parse-qstring val) #t)))
830 (define (entity-tag? val)
832 (string? (car val))))
834 (define (write-entity-tag val port)
837 (write-qstring (car val) port))
839 (define* (parse-entity-tag-list val #:optional
840 (start 0) (end (string-length val)))
841 (let ((strong? (not (string-prefix? "W/" val 0 2 start end))))
842 (call-with-values (lambda ()
843 (parse-qstring val (if strong? start (+ start 2))
844 end #:incremental? #t))
847 (let ((next (skip-whitespace val next end)))
849 (if (eqv? (string-ref val next) #\,)
850 (parse-entity-tag-list
852 (skip-whitespace val (1+ next) end)
854 (bad-header-component 'entity-tag-list val))
857 (define (entity-tag-list? val)
858 (list-of? val entity-tag?))
860 (define (write-entity-tag-list val port)
861 (write-list val port write-entity-tag ", "))
863 ;; credentials = auth-scheme #auth-param
864 ;; auth-scheme = token
865 ;; auth-param = token "=" ( token | quoted-string )
867 ;; That's what the spec says. In reality the Basic scheme doesn't have
868 ;; k-v pairs, just one auth token, so we give that token as a string.
870 (define* (parse-credentials str #:optional (val-parser default-val-parser)
871 (start 0) (end (string-length str)))
872 (let* ((start (skip-whitespace str start end))
873 (delim (or (string-index str char-set:whitespace start end) end)))
875 (bad-header-component 'authorization str))
876 (let ((scheme (string->symbol
877 (string-downcase (substring str start (or delim end))))))
880 (let* ((start (skip-whitespace str delim end)))
882 (cons scheme (substring str start end))
883 (bad-header-component 'credentials str))))
885 (cons scheme (parse-key-value-list str default-val-parser delim end)))))))
887 (define (validate-credentials val)
888 (and (pair? val) (symbol? (car val))
890 ((basic) (string? (cdr val)))
891 (else (key-value-list? (cdr val))))))
893 (define (write-credentials val port)
894 (display (car val) port)
895 (if (pair? (cdr val))
897 (display #\space port)
898 (write-key-value-list (cdr val) port))))
900 ;; challenges = 1#challenge
901 ;; challenge = auth-scheme 1*SP 1#auth-param
903 ;; A pain to parse, as both challenges and auth params are delimited by
904 ;; commas, and qstrings can contain anything. We rely on auth params
905 ;; necessarily having "=" in them.
907 (define* (parse-challenge str #:optional
908 (start 0) (end (string-length str)))
909 (let* ((start (skip-whitespace str start end))
910 (sp (string-index str #\space start end))
912 (string->symbol (string-downcase (substring str start sp)))
913 (bad-header-component 'challenge str))))
914 (let lp ((i sp) (out (list scheme)))
916 (values (reverse! out) end)
917 (let* ((i (skip-whitespace str i end))
918 (eq (string-index str #\= i end))
919 (comma (string-index str #\, i end))
920 (delim (min (or eq end) (or comma end)))
921 (token-end (trim-whitespace str i delim)))
922 (if (string-index str #\space i token-end)
923 (values (reverse! out) i)
924 (let ((k (string->symbol (substring str i token-end))))
927 (if (and eq (or (not comma) (< eq comma)))
928 (let ((i (skip-whitespace str (1+ eq) end)))
929 (if (and (< i end) (eqv? (string-ref str i) #\"))
930 (parse-qstring str i end #:incremental? #t)
933 (trim-whitespace str i
938 (let ((i (skip-whitespace str next-i end)))
939 (if (or (= i end) (eqv? (string-ref str i) #\,))
940 (lp (1+ i) (cons (if v (cons k v) k) out))
941 (bad-header-component
943 (substring str start end)))))))))))))
945 (define* (parse-challenges str #:optional (val-parser default-val-parser)
946 (start 0) (end (string-length str)))
947 (let lp ((i start) (ret '()))
948 (let ((i (skip-whitespace str i end)))
950 (call-with-values (lambda () (parse-challenge str i end))
951 (lambda (challenge i)
952 (lp i (cons challenge ret))))
955 (define (validate-challenges val)
956 (list-of? val (lambda (x)
957 (and (pair? x) (symbol? (car x))
958 (key-value-list? (cdr x))))))
960 (define (write-challenge val port)
961 (display (car val) port)
962 (display #\space port)
963 (write-key-value-list (cdr val) port))
965 (define (write-challenges val port)
966 (write-list val port write-challenge ", "))
972 ;;; Request-Line and Response-Line
976 (define (bad-request message . args)
977 (throw 'bad-request message args))
978 (define (bad-response message . args)
979 (throw 'bad-response message args))
981 (define *known-versions* '())
983 (define* (parse-http-version str #:optional (start 0) (end (string-length str)))
984 "Parse an HTTP version from @var{str}, returning it as a major-minor
985 pair. For example, @code{HTTP/1.1} parses as the pair of integers,
987 (or (let lp ((known *known-versions*))
989 (if (string= str (caar known) start end)
992 (let ((dot-idx (string-index str #\. start end)))
993 (if (and (string-prefix? "HTTP/" str 0 5 start end)
995 (= dot-idx (string-rindex str #\. start end)))
996 (cons (parse-non-negative-integer str (+ start 5) dot-idx)
997 (parse-non-negative-integer str (1+ dot-idx) end))
998 (bad-header-component 'http-version (substring str start end))))))
1000 (define (write-http-version val port)
1001 "Write the given major-minor version pair to @var{port}."
1002 (display "HTTP/" port)
1003 (display (car val) port)
1005 (display (cdr val) port))
1009 (set! *known-versions*
1010 (acons v (parse-http-version v 0 (string-length v))
1012 '("HTTP/1.0" "HTTP/1.1"))
1015 ;; Request-URI = "*" | absoluteURI | abs_path | authority
1017 ;; The `authority' form is only permissible for the CONNECT method, so
1018 ;; because we don't expect people to implement CONNECT, we save
1019 ;; ourselves the trouble of that case, and disallow the CONNECT method.
1021 (define* (parse-http-method str #:optional (start 0) (end (string-length str)))
1022 "Parse an HTTP method from @var{str}. The result is an upper-case
1023 symbol, like @code{GET}."
1025 ((string= str "GET" start end) 'GET)
1026 ((string= str "HEAD" start end) 'HEAD)
1027 ((string= str "POST" start end) 'POST)
1028 ((string= str "PUT" start end) 'PUT)
1029 ((string= str "DELETE" start end) 'DELETE)
1030 ((string= str "OPTIONS" start end) 'OPTIONS)
1031 ((string= str "TRACE" start end) 'TRACE)
1032 (else (bad-request "Invalid method: ~a" (substring str start end)))))
1034 (define* (parse-request-uri str #:optional (start 0) (end (string-length str)))
1035 "Parse a URI from an HTTP request line. Note that URIs in requests do
1036 not have to have a scheme or host name. The result is a URI object."
1039 (bad-request "Missing Request-URI"))
1040 ((string= str "*" start end)
1042 ((eq? (string-ref str start) #\/)
1043 (let* ((q (string-index str #\? start end))
1044 (f (string-index str #\# start end))
1045 (q (and q (or (not f) (< q f)) q)))
1047 #:path (substring str start (or q f end))
1048 #:query (and q (substring str (1+ q) (or f end)))
1049 #:fragment (and f (substring str (1+ f) end)))))
1051 (or (string->uri (substring str start end))
1052 (bad-request "Invalid URI: ~a" (substring str start end))))))
1054 (define (read-request-line port)
1055 "Read the first line of an HTTP request from @var{port}, returning
1056 three values: the method, the URI, and the version."
1057 (let* ((line (read-line* port))
1058 (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
1059 (d1 (string-rindex line char-set:whitespace)))
1060 (if (and d0 d1 (< d0 d1))
1061 (values (parse-http-method line 0 d0)
1062 (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
1063 (parse-http-version line (1+ d1) (string-length line)))
1064 (bad-request "Bad Request-Line: ~s" line))))
1066 (define (write-uri uri port)
1069 (display (uri-scheme uri) port)
1070 (display "://" port)
1071 (if (uri-userinfo uri)
1073 (display (uri-userinfo uri) port)
1074 (display #\@ port)))
1075 (display (uri-host uri) port)
1076 (let ((p (uri-port uri)))
1077 (if (and p (not (eqv? p 80)))
1080 (display p port))))))
1081 (let* ((path (uri-path uri))
1082 (len (string-length path)))
1084 ((and (> len 0) (not (eqv? (string-ref path 0) #\/)))
1085 (bad-request "Non-absolute URI path: ~s" path))
1086 ((and (zero? len) (not (uri-host uri)))
1087 (bad-request "Empty path and no host for URI: ~s" uri))
1089 (display path port))))
1093 (display (uri-query uri) port))))
1095 (define (write-request-line method uri version port)
1096 "Write the first line of an HTTP request to @var{port}."
1097 (display method port)
1098 (display #\space port)
1099 (let ((path (uri-path uri))
1100 (query (uri-query uri)))
1101 (if (not (string-null? path))
1102 (display path port))
1106 (display query port)))
1107 (if (and (string-null? path)
1109 ;; Make sure we display something.
1110 (display "/" port)))
1111 (display #\space port)
1112 (write-http-version version port)
1113 (display "\r\n" port))
1115 (define (read-response-line port)
1116 "Read the first line of an HTTP response from @var{port}, returning
1117 three values: the HTTP version, the response code, and the \"reason
1119 (let* ((line (read-line* port))
1120 (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
1121 (d1 (and d0 (string-index line char-set:whitespace
1122 (skip-whitespace line d0)))))
1124 (values (parse-http-version line 0 d0)
1125 (parse-non-negative-integer line (skip-whitespace line d0 d1)
1127 (string-trim-both line char-set:whitespace d1))
1128 (bad-response "Bad Response-Line: ~s" line))))
1130 (define (write-response-line version code reason-phrase port)
1131 "Write the first line of an HTTP response to @var{port}."
1132 (write-http-version version port)
1133 (display #\space port)
1135 (display #\space port)
1136 (display reason-phrase port)
1137 (display "\r\n" port))
1143 ;;; Helpers for declaring headers
1146 ;; emacs: (put 'declare-header! 'scheme-indent-function 1)
1147 ;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
1148 (define (declare-opaque-header! name)
1149 "Declares a given header as \"opaque\", meaning that its value is not
1150 treated specially, and is just returned as a plain string."
1151 (declare-header! name
1152 parse-opaque-string validate-opaque-string write-opaque-string))
1154 ;; emacs: (put 'declare-date-header! 'scheme-indent-function 1)
1155 (define (declare-date-header! name)
1156 (declare-header! name
1157 parse-date date? write-date))
1159 ;; emacs: (put 'declare-string-list-header! 'scheme-indent-function 1)
1160 (define (declare-string-list-header! name)
1161 (declare-header! name
1162 split-and-trim list-of-strings? write-list-of-strings))
1164 ;; emacs: (put 'declare-symbol-list-header! 'scheme-indent-function 1)
1165 (define (declare-symbol-list-header! name)
1166 (declare-header! name
1168 (map string->symbol (split-and-trim str)))
1170 (list-of? v symbol?))
1172 (write-list v port display ", "))))
1174 ;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1)
1175 (define (declare-header-list-header! name)
1176 (declare-header! name
1177 split-header-names list-of-header-names? write-header-list))
1179 ;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1)
1180 (define (declare-integer-header! name)
1181 (declare-header! name
1182 parse-non-negative-integer non-negative-integer? display))
1184 ;; emacs: (put 'declare-uri-header! 'scheme-indent-function 1)
1185 (define (declare-uri-header! name)
1186 (declare-header! name
1187 (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
1191 ;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1)
1192 (define (declare-quality-list-header! name)
1193 (declare-header! name
1194 parse-quality-list validate-quality-list write-quality-list))
1196 ;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1)
1197 (define* (declare-param-list-header! name #:optional
1198 (val-parser default-val-parser)
1199 (val-validator default-val-validator)
1200 (val-writer default-val-writer))
1201 (declare-header! name
1202 (lambda (str) (parse-param-list str val-parser))
1203 (lambda (val) (validate-param-list val val-validator))
1204 (lambda (val port) (write-param-list val port val-writer))))
1206 ;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1)
1207 (define* (declare-key-value-list-header! name #:optional
1208 (val-parser default-val-parser)
1209 (val-validator default-val-validator)
1210 (val-writer default-val-writer))
1211 (declare-header! name
1212 (lambda (str) (parse-key-value-list str val-parser))
1213 (lambda (val) (key-value-list? val val-validator))
1214 (lambda (val port) (write-key-value-list val port val-writer))))
1216 ;; emacs: (put 'declare-entity-tag-list-header! 'scheme-indent-function 1)
1217 (define (declare-entity-tag-list-header! name)
1218 (declare-header! name
1219 (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str)))
1220 (lambda (val) (or (eq? val '*) (entity-tag-list? val)))
1224 (write-entity-tag-list val port)))))
1226 ;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1)
1227 (define (declare-credentials-header! name)
1228 (declare-header! name
1229 parse-credentials validate-credentials write-credentials))
1231 ;; emacs: (put 'declare-challenge-list-header! 'scheme-indent-function 1)
1232 (define (declare-challenge-list-header! name)
1233 (declare-header! name
1234 parse-challenges validate-challenges write-challenges))
1243 ;; Cache-Control = 1#(cache-directive)
1244 ;; cache-directive = cache-request-directive | cache-response-directive
1245 ;; cache-request-directive =
1246 ;; "no-cache" ; Section 14.9.1
1247 ;; | "no-store" ; Section 14.9.2
1248 ;; | "max-age" "=" delta-seconds ; Section 14.9.3, 14.9.4
1249 ;; | "max-stale" [ "=" delta-seconds ] ; Section 14.9.3
1250 ;; | "min-fresh" "=" delta-seconds ; Section 14.9.3
1251 ;; | "no-transform" ; Section 14.9.5
1252 ;; | "only-if-cached" ; Section 14.9.4
1253 ;; | cache-extension ; Section 14.9.6
1254 ;; cache-response-directive =
1255 ;; "public" ; Section 14.9.1
1256 ;; | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1
1257 ;; | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1
1258 ;; | "no-store" ; Section 14.9.2
1259 ;; | "no-transform" ; Section 14.9.5
1260 ;; | "must-revalidate" ; Section 14.9.4
1261 ;; | "proxy-revalidate" ; Section 14.9.4
1262 ;; | "max-age" "=" delta-seconds ; Section 14.9.3
1263 ;; | "s-maxage" "=" delta-seconds ; Section 14.9.3
1264 ;; | cache-extension ; Section 14.9.6
1265 ;; cache-extension = token [ "=" ( token | quoted-string ) ]
1267 (declare-key-value-list-header! "Cache-Control"
1270 ((max-age min-fresh s-maxage)
1271 (parse-non-negative-integer v-str))
1273 (and v-str (parse-non-negative-integer v-str)))
1275 (and v-str (split-header-names v-str)))
1279 ((max-age min-fresh s-maxage)
1280 (non-negative-integer? v))
1282 (or (not v) (non-negative-integer? v)))
1284 (or (not v) (list-of-header-names? v)))
1285 ((no-store no-transform only-if-cache must-revalidate proxy-revalidate)
1288 (or (not v) (string? v)))))
1291 ((string? v) (default-val-writer k v port))
1294 (write-header-list v port)
1299 (bad-header-component 'cache-control v)))))
1301 ;; Connection = "Connection" ":" 1#(connection-token)
1302 ;; connection-token = token
1304 ;; Connection: close, foo-header
1306 (declare-header-list-header! "Connection")
1308 ;; Date = "Date" ":" HTTP-date
1310 ;; Date: Tue, 15 Nov 1994 08:12:31 GMT
1312 (declare-date-header! "Date")
1314 ;; Pragma = "Pragma" ":" 1#pragma-directive
1315 ;; pragma-directive = "no-cache" | extension-pragma
1316 ;; extension-pragma = token [ "=" ( token | quoted-string ) ]
1318 (declare-key-value-list-header! "Pragma")
1320 ;; Trailer = "Trailer" ":" 1#field-name
1322 (declare-header-list-header! "Trailer")
1324 ;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding
1326 (declare-param-list-header! "Transfer-Encoding")
1328 ;; Upgrade = "Upgrade" ":" 1#product
1330 (declare-string-list-header! "Upgrade")
1332 ;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] )
1333 ;; received-protocol = [ protocol-name "/" ] protocol-version
1334 ;; protocol-name = token
1335 ;; protocol-version = token
1336 ;; received-by = ( host [ ":" port ] ) | pseudonym
1337 ;; pseudonym = token
1339 (declare-header! "Via"
1342 write-list-of-strings
1345 ;; Warning = "Warning" ":" 1#warning-value
1347 ;; warning-value = warn-code SP warn-agent SP warn-text
1350 ;; warn-code = 3DIGIT
1351 ;; warn-agent = ( host [ ":" port ] ) | pseudonym
1352 ;; ; the name or pseudonym of the server adding
1353 ;; ; the Warning header, for use in debugging
1354 ;; warn-text = quoted-string
1355 ;; warn-date = <"> HTTP-date <">
1356 (declare-header! "Warning"
1358 (let ((len (string-length str)))
1359 (let lp ((i (skip-whitespace str 0)))
1360 (let* ((idx1 (string-index str #\space i))
1361 (idx2 (string-index str #\space (1+ idx1))))
1363 (let ((code (parse-non-negative-integer str i idx1))
1364 (agent (substring str (1+ idx1) idx2)))
1366 (lambda () (parse-qstring str (1+ idx2) #:incremental? #t))
1370 (let ((c (and (< i len) (string-ref str i))))
1375 (lambda () (parse-qstring str (1+ i)
1378 (values text (parse-date date) i))))
1380 (values text #f i)))))
1381 (lambda (text date i)
1382 (let ((w (list code agent text date))
1383 (c (and (< i len) (string-ref str i))))
1386 ((#\,) (cons w (lp (skip-whitespace str (1+ i)))))
1387 (else (bad-header 'warning str))))))))))))))
1393 (apply (lambda (code host text date)
1394 (and (non-negative-integer? code) (< code 1000)
1397 (or (not date) (date? date))))
1404 (lambda (code host text date)
1406 (display #\space port)
1408 (display #\space port)
1409 (write-qstring text port)
1412 (display #\space port)
1413 (write-date date port))))
1427 (declare-symbol-list-header! "Allow")
1429 ;; Content-Encoding = 1#content-coding
1431 (declare-symbol-list-header! "Content-Encoding")
1433 ;; Content-Language = 1#language-tag
1435 (declare-string-list-header! "Content-Language")
1437 ;; Content-Length = 1*DIGIT
1439 (declare-integer-header! "Content-Length")
1441 ;; Content-Location = ( absoluteURI | relativeURI )
1443 (declare-uri-header! "Content-Location")
1445 ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
1447 (declare-opaque-header! "Content-MD5")
1449 ;; Content-Range = content-range-spec
1450 ;; content-range-spec = byte-content-range-spec
1451 ;; byte-content-range-spec = bytes-unit SP
1452 ;; byte-range-resp-spec "/"
1453 ;; ( instance-length | "*" )
1454 ;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos)
1456 ;; instance-length = 1*DIGIT
1458 (declare-header! "Content-Range"
1460 (let ((dash (string-index str #\-))
1461 (slash (string-index str #\/)))
1462 (if (and (string-prefix? "bytes " str) slash)
1467 (parse-non-negative-integer str 6 dash)
1468 (parse-non-negative-integer str (1+ dash) slash)))
1469 ((string= str "*" 6 slash)
1472 (bad-header 'content-range str)))
1473 (if (string= str "*" (1+ slash))
1475 (parse-non-negative-integer str (1+ slash))))
1476 (bad-header 'content-range str))))
1478 (and (list? val) (= (length val) 3)
1480 (let ((x (cadr val)))
1483 (non-negative-integer? (car x))
1484 (non-negative-integer? (cdr x)))))
1485 (let ((x (caddr val)))
1487 (non-negative-integer? x)))))
1489 (display (car val) port)
1490 (display #\space port)
1491 (if (eq? (cadr val) '*)
1494 (display (caadr val) port)
1496 (display (caadr val) port)))
1497 (if (eq? (caddr val) '*)
1499 (display (caddr val) port))))
1501 ;; Content-Type = media-type
1503 (declare-header! "Content-Type"
1505 (let ((parts (string-split str #\;)))
1506 (cons (parse-media-type (car parts))
1508 (let ((eq (string-index x #\=)))
1509 (if (and eq (= eq (string-rindex x #\=)))
1512 (string-trim x char-set:whitespace 0 eq))
1513 (string-trim-right x char-set:whitespace (1+ eq)))
1514 (bad-header 'content-type str))))
1521 (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
1523 (display (car val) port)
1524 (if (pair? (cdr val))
1530 (display (car pair) port)
1532 (display (cdr pair) port))
1535 ;; Expires = HTTP-date
1537 (define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT"))
1539 (declare-header! "Expires"
1541 (if (member str '("0" "-1"))
1547 ;; Last-Modified = HTTP-date
1549 (declare-date-header! "Last-Modified")
1558 ;; Accept = #( media-range [ accept-params ] )
1559 ;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) )
1560 ;; *( ";" parameter )
1561 ;; accept-params = ";" "q" "=" qvalue *( accept-extension )
1562 ;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
1564 (declare-param-list-header! "Accept"
1565 ;; -> (type/subtype (sym-prop . str-val) ...) ...)
1567 ;; with the exception of prop `q', in which case the val will be a
1568 ;; valid quality value
1577 (or (not v) (string? v))))
1580 (write-quality v port)
1581 (default-val-writer k v port))))
1583 ;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] )
1585 (declare-quality-list-header! "Accept-Charset")
1587 ;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] )
1588 ;; codings = ( content-coding | "*" )
1590 (declare-quality-list-header! "Accept-Encoding")
1592 ;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] )
1593 ;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )
1595 (declare-quality-list-header! "Accept-Language")
1597 ;; Authorization = credentials
1598 ;; credentials = auth-scheme #auth-param
1599 ;; auth-scheme = token
1600 ;; auth-param = token "=" ( token | quoted-string )
1602 (declare-credentials-header! "Authorization")
1604 ;; Expect = 1#expectation
1605 ;; expectation = "100-continue" | expectation-extension
1606 ;; expectation-extension = token [ "=" ( token | quoted-string )
1608 ;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
1610 (declare-param-list-header! "Expect")
1614 ;; Should be an email address; we just pass on the string as-is.
1616 (declare-opaque-header! "From")
1618 ;; Host = host [ ":" port ]
1620 (declare-header! "Host"
1622 (let ((colon (string-index str #\:)))
1624 (cons (substring str 0 colon)
1625 (parse-non-negative-integer str (1+ colon)))
1631 (non-negative-integer? (cdr val)))))
1633 (display (car val) port)
1637 (display (cdr val) port)))))
1639 ;; If-Match = ( "*" | 1#entity-tag )
1641 (declare-entity-tag-list-header! "If-Match")
1643 ;; If-Modified-Since = HTTP-date
1645 (declare-date-header! "If-Modified-Since")
1647 ;; If-None-Match = ( "*" | 1#entity-tag )
1649 (declare-entity-tag-list-header! "If-None-Match")
1651 ;; If-Range = ( entity-tag | HTTP-date )
1653 (declare-header! "If-Range"
1655 (if (or (string-prefix? "\"" str)
1656 (string-prefix? "W/" str))
1657 (parse-entity-tag str)
1660 (or (date? val) (entity-tag? val)))
1663 (write-date val port)
1664 (write-entity-tag val port))))
1666 ;; If-Unmodified-Since = HTTP-date
1668 (declare-date-header! "If-Unmodified-Since")
1670 ;; Max-Forwards = 1*DIGIT
1672 (declare-integer-header! "Max-Forwards")
1674 ;; Proxy-Authorization = credentials
1676 (declare-credentials-header! "Proxy-Authorization")
1678 ;; Range = "Range" ":" ranges-specifier
1679 ;; ranges-specifier = byte-ranges-specifier
1680 ;; byte-ranges-specifier = bytes-unit "=" byte-range-set
1681 ;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec )
1682 ;; byte-range-spec = first-byte-pos "-" [last-byte-pos]
1683 ;; first-byte-pos = 1*DIGIT
1684 ;; last-byte-pos = 1*DIGIT
1685 ;; suffix-byte-range-spec = "-" suffix-length
1686 ;; suffix-length = 1*DIGIT
1688 (declare-header! "Range"
1690 (if (string-prefix? "bytes=" str)
1694 (let ((dash (string-index x #\-)))
1697 (bad-header 'range str))
1699 (cons #f (parse-non-negative-integer x 1)))
1700 ((= dash (1- (string-length x)))
1701 (cons (parse-non-negative-integer x 0 dash) #f))
1703 (cons (parse-non-negative-integer x 0 dash)
1704 (parse-non-negative-integer x (1+ dash)))))))
1705 (string-split (substring str 6) #\,)))
1706 (bad-header 'range str)))
1713 (let ((x (car elt)) (y (cdr elt)))
1715 (or (not x) (non-negative-integer? x))
1716 (or (not y) (non-negative-integer? y)))))))))
1718 (display (car val) port)
1724 (display (car pair) port))
1727 (display (cdr pair) port)))
1730 ;; Referer = ( absoluteURI | relativeURI )
1732 (declare-uri-header! "Referer")
1734 ;; TE = #( t-codings )
1735 ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
1737 (declare-param-list-header! "TE")
1739 ;; User-Agent = 1*( product | comment )
1741 (declare-opaque-header! "User-Agent")
1750 ;; Accept-Ranges = acceptable-ranges
1751 ;; acceptable-ranges = 1#range-unit | "none"
1753 (declare-symbol-list-header! "Accept-Ranges")
1756 ;; age-value = delta-seconds
1758 (declare-integer-header! "Age")
1760 ;; ETag = entity-tag
1762 (declare-header! "ETag"
1767 ;; Location = absoluteURI
1769 (declare-uri-header! "Location")
1771 ;; Proxy-Authenticate = 1#challenge
1773 (declare-challenge-list-header! "Proxy-Authenticate")
1775 ;; Retry-After = ( HTTP-date | delta-seconds )
1777 (declare-header! "Retry-After"
1779 (if (and (not (string-null? str))
1780 (char-numeric? (string-ref str 0)))
1781 (parse-non-negative-integer str)
1784 (or (date? val) (non-negative-integer? val)))
1787 (write-date val port)
1788 (display val port))))
1790 ;; Server = 1*( product | comment )
1792 (declare-opaque-header! "Server")
1794 ;; Vary = ( "*" | 1#field-name )
1796 (declare-header! "Vary"
1798 (if (equal? str "*")
1800 (split-header-names str)))
1802 (or (eq? val '*) (list-of-header-names? val)))
1806 (write-header-list val port))))
1808 ;; WWW-Authenticate = 1#challenge
1810 (declare-challenge-list-header! "WWW-Authenticate")
1813 ;; Chunked Responses
1814 (define (read-chunk-header port)
1815 (let* ((str (read-line port))
1816 (extension-start (string-index str (lambda (c) (or (char=? c #\;)
1817 (char=? c #\return)))))
1818 (size (string->number (if extension-start ; unnecessary?
1819 (substring str 0 extension-start)
1824 (define (read-chunk port)
1825 (let ((size (read-chunk-header port)))
1826 (read-chunk-body port size)))
1828 (define (read-chunk-body port size)
1829 (let ((bv (get-bytevector-n port size)))
1834 (define* (make-chunked-input-port port #:key (keep-alive? #f))
1835 "Returns a new port which translates HTTP chunked transfer encoded
1836 data from @var{port} into a non-encoded format. Returns eof when it has
1837 read the final chunk from @var{port}. This does not necessarily mean
1838 that there is no more data on @var{port}. When the returned port is
1839 closed it will also close @var{port}, unless the KEEP-ALIVE? is true."
1840 (define (next-chunk)
1842 (define finished? #f)
1846 (define buffer #vu8())
1847 (define buffer-size 0)
1848 (define buffer-pointer 0)
1849 (define (read! bv idx to-read)
1850 (define (loop to-read num-read)
1851 (cond ((or finished? (zero? to-read))
1853 ((<= to-read (- buffer-size buffer-pointer))
1854 (bytevector-copy! buffer buffer-pointer
1857 (set! buffer-pointer (+ buffer-pointer to-read))
1858 (loop 0 (+ num-read to-read)))
1860 (let ((n (- buffer-size buffer-pointer)))
1861 (bytevector-copy! buffer buffer-pointer
1864 (set! buffer (next-chunk))
1865 (set! buffer-pointer 0)
1866 (set! buffer-size (bytevector-length buffer))
1867 (set! finished? (= buffer-size 0))
1871 (make-custom-binary-input-port "chunked input port" read! #f #f close))
1873 (define* (make-chunked-output-port port #:key (keep-alive? #f))
1874 "Returns a new port which translates non-encoded data into a HTTP
1875 chunked transfer encoded data and writes this to @var{port}. Data
1876 written to this port is buffered until the port is flushed, at which
1877 point it is all sent as one chunk. Take care to close the port when
1878 done, as it will output the remaining data, and encode the final zero
1879 chunk. When the port is closed it will also close @var{port}, unless
1880 KEEP-ALIVE? is true."
1881 (define (q-for-each f q)
1882 (while (not (q-empty? q))
1884 (define queue (make-q))
1885 (define (put-char c)
1887 (define (put-string s)
1888 (string-for-each (lambda (c) (enq! queue c))
1891 ;; It is important that we do _not_ write a chunk if the queue is
1892 ;; empty, since it will be treated as the final chunk.
1893 (unless (q-empty? queue)
1894 (let ((len (q-length queue)))
1895 (display (number->string len 16) port)
1896 (display "\r\n" port)
1897 (q-for-each (lambda (elem) (write-char elem port))
1899 (display "\r\n" port))))
1902 (display "0\r\n" port)
1906 (make-soft-port (vector put-char put-string flush #f close) "w"))