;;; HTTP messages
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA
+;;; Commentary:
+;;;
+;;; This module has a number of routines to parse textual
+;;; representations of HTTP data into native Scheme data structures.
+;;;
+;;; It tries to follow RFCs fairly strictly---the road to perdition
+;;; being paved with compatibility hacks---though some allowances are
+;;; made for not-too-divergent texts (like a quality of .2 which should
+;;; be 0.2, etc).
+;;;
;;; Code:
(define-module (web http)
#:use-module ((srfi srfi-1) #:select (append-map! map!))
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
- #:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (web uri)
- #:export (header-decl?
- make-header-decl
- header-decl-sym
- header-decl-name
- header-decl-multiple?
- header-decl-parser
- header-decl-validator
- header-decl-writer
- lookup-header-decl
+ #:export (string->header
+ header->string
+
declare-header!
+ known-header?
+ header-parser
+ header-validator
+ header-writer
read-header
parse-header
;;;
+(define (string->header name)
+ "Parse @var{name} to a symbolic header name."
+ (string->symbol (string-downcase name)))
+
(define-record-type <header-decl>
- (make-header-decl sym name multiple? parser validator writer)
+ (make-header-decl name parser validator writer multiple?)
header-decl?
- (sym header-decl-sym)
(name header-decl-name)
- (multiple? header-decl-multiple?)
(parser header-decl-parser)
(validator header-decl-validator)
- (writer header-decl-writer))
+ (writer header-decl-writer)
+ (multiple? header-decl-multiple?))
;; sym -> header
(define *declared-headers* (make-hash-table))
-;; downcased name -> header
-(define *declared-headers-by-name* (make-hash-table))
-(define* (declare-header! sym name #:key
- multiple?
+(define (lookup-header-decl sym)
+ (hashq-ref *declared-headers* sym))
+
+(define* (declare-header! name
parser
validator
- writer)
- (if (and (symbol? sym) (string? name) parser validator writer)
- (let ((decl (make-header-decl sym name
- multiple? parser validator writer)))
- (hashq-set! *declared-headers* sym decl)
- (hash-set! *declared-headers-by-name* (string-downcase name) decl)
+ writer
+ #:key multiple?)
+ "Define a parser, validator, and writer for the HTTP header, @var{name}.
+
+@var{parser} should be a procedure that takes a string and returns a
+Scheme value. @var{validator} is a predicate for whether the given
+Scheme value is valid for this header. @var{writer} takes a value and a
+port, and writes the value to the port."
+ (if (and (string? name) parser validator writer)
+ (let ((decl (make-header-decl name parser validator writer multiple?)))
+ (hashq-set! *declared-headers* (string->header name) decl)
decl)
- (error "bad header decl" sym name multiple? parser validator writer)))
+ (error "bad header decl" name parser validator writer multiple?)))
+
+(define (header->string sym)
+ "Return the string form for the header named @var{sym}."
+ (let ((decl (lookup-header-decl sym)))
+ (if decl
+ (header-decl-name decl)
+ (string-titlecase (symbol->string sym)))))
+
+(define (known-header? sym)
+ "Return @code{#t} if there are parsers and writers registered for this
+header, otherwise @code{#f}."
+ (and (lookup-header-decl sym) #t))
+
+(define (header-parser sym)
+ "Returns a procedure to parse values for the given header."
+ (let ((decl (lookup-header-decl sym)))
+ (if decl
+ (header-decl-parser decl)
+ (lambda (x) x))))
+
+(define (header-validator sym)
+ "Returns a procedure to validate values for the given header."
+ (let ((decl (lookup-header-decl sym)))
+ (if decl
+ (header-decl-validator decl)
+ string?)))
+
+(define (header-writer sym)
+ "Returns a procedure to write values for the given header to a given
+port."
+ (let ((decl (lookup-header-decl sym)))
+ (if decl
+ (header-decl-writer decl)
+ display)))
(define (read-line* port)
(let* ((pair (%read-line port))
(read-line* port))))
val))
+(define *eof* (call-with-input-string "" read))
+
(define (read-header port)
+ "Reads one HTTP header from @var{port}. Returns two values: the header
+name and the parsed Scheme value. May raise an exception if the header
+was known but the value was invalid.
+
+Returns the end-of-file object for both values if the end of the message
+body was reached (i.e., a blank line)."
(let ((line (read-line* port)))
(if (or (string-null? line)
(string=? line "\r"))
- (values #f #f)
- (let ((delim (or (string-index line #\:)
- (bad-header '%read line))))
- (parse-header
- (substring line 0 delim)
- (read-continuation-line
- port
- (string-trim-both line char-whitespace? (1+ delim))))))))
-
-(define (lookup-header-decl name)
- (if (string? name)
- (hash-ref *declared-headers-by-name* (string-downcase name))
- (hashq-ref *declared-headers* name)))
-
-(define (parse-header name val)
- (let* ((down (string-downcase name))
- (decl (hash-ref *declared-headers-by-name* down)))
- (if decl
- (values (header-decl-sym decl)
- ((header-decl-parser decl) val))
- (values down val))))
+ (values *eof* *eof*)
+ (let* ((delim (or (string-index line #\:)
+ (bad-header '%read line)))
+ (sym (string->header (substring line 0 delim))))
+ (values
+ sym
+ (parse-header
+ sym
+ (read-continuation-line
+ port
+ (string-trim-both line char-whitespace? (1+ delim)))))))))
+
+(define (parse-header sym val)
+ "Parse @var{val}, a string, with the parser registered for the header
+named @var{sym}.
+
+Returns the parsed value. If a parser was not found, the value is
+returned as a string."
+ ((header-parser sym) val))
(define (valid-header? sym val)
- (let ((decl (hashq-ref *declared-headers* sym)))
- (if (not decl)
- (error "Unknown header" sym)
- ((header-decl-validator decl) val))))
-
-(define (write-header name val port)
- (if (string? name)
- ;; assume that it's a header we don't know about...
- (begin
- (display name port)
- (display ": " port)
- (display val port)
- (display "\r\n" port))
- (let ((decl (hashq-ref *declared-headers* name)))
- (if (not decl)
- (error "Unknown header" name)
- (begin
- (display (header-decl-name decl) port)
- (display ": " port)
- ((header-decl-writer decl) val port)
- (display "\r\n" port))))))
+ "Returns a true value iff @var{val} is a valid Scheme value for the
+header with name @var{sym}."
+ (if (symbol? sym)
+ ((header-validator sym) val)
+ (error "header name not a symbol" sym)))
+
+(define (write-header sym val port)
+ "Writes the given header name and value to @var{port}. If @var{sym}
+is a known header, uses the specific writer registered for that header.
+Otherwise the value is written using @code{display}."
+ (display (header->string sym) port)
+ (display ": " port)
+ ((header-writer sym) val port)
+ (display "\r\n" port))
(define (read-headers port)
+ "Read an HTTP message from @var{port}, returning the headers as an
+ordered alist."
(let lp ((headers '()))
(call-with-values (lambda () (read-header port))
(lambda (k v)
- (if k
- (lp (acons k v headers))
- (reverse! headers))))))
+ (if (eof-object? k)
+ (reverse! headers)
+ (lp (acons k v headers)))))))
-;; Doesn't write the final \r\n, as the user might want to add another
-;; header.
(define (write-headers headers port)
+ "Write the given header alist to @var{port}. Doesn't write the final
+\\r\\n, as the user might want to add another header."
(let lp ((headers headers))
(if (pair? headers)
(begin
(define (write-opaque-string val port)
(display val port))
-(define not-separator
- "[^][()<>@,;:\\\"/?= \t]")
-(define media-type-re
- (make-regexp (format #f "^(~a+)/(~a+)$" not-separator not-separator)))
+(define separators-without-slash
+ (string->char-set "[^][()<>@,;:\\\"?= \t]"))
+(define (validate-media-type str)
+ (let ((idx (string-index str #\/)))
+ (and idx (= idx (string-rindex str #\/))
+ (not (string-index str separators-without-slash)))))
(define (parse-media-type str)
- (let ((m (regexp-exec media-type-re str)))
- (if m
- (values (match:substring m 1) (match:substring m 2))
- (bad-header-component 'media-type str))))
+ (if (validate-media-type str)
+ (string->symbol str)
+ (bad-header-component 'media-type str)))
(define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
(let lp ((i start))
(cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
'())))
+(define (list-of-strings? val)
+ (list-of? val string?))
+
+(define (write-list-of-strings val port)
+ (write-list val port display ", "))
+
+(define (split-header-names str)
+ (map string->header (split-and-trim str)))
+
+(define (list-of-header-names? val)
+ (list-of? val symbol?))
+
+(define (write-header-list val port)
+ (write-list val port
+ (lambda (x port)
+ (display (header->string x) port))
+ ", "))
+
(define (collect-escaped-string from start len escapes)
(let ((to (make-string len)))
(let lp ((start start) (i 0) (escapes escapes))
(+ q (* place (char->decimal (string-ref str i))))
q))))
(bad-header-component 'quality str))))
+ ;; Allow the nonstandard .2 instead of 0.2.
+ ((and (eqv? (string-ref str start) #\.)
+ (< 1 (- end start) 5))
+ (let lp ((place 1) (i (+ start 3)) (q 0))
+ (if (= i start)
+ q
+ (lp (* 10 place) (1- i)
+ (if (< i end)
+ (+ q (* place (char->decimal (string-ref str i))))
+ q)))))
(else
(bad-header-component 'quality str))))
(define (valid-quality? q)
- (and (non-negative-integer? q) (<= 1000 q)))
+ (and (non-negative-integer? q) (<= q 1000)))
(define (write-quality q port)
(define (digit->char d)
(define (non-negative-integer? code)
(and (number? code) (>= code 0) (exact? code) (integer? code)))
-(define (default-kons k val)
- (if val
- (cons k val)
- k))
+(define (default-val-parser k val)
+ val)
-(define (default-kv-validator k val)
- #t)
+(define (default-val-validator k val)
+ (or (not val) (string? val)))
(define (default-val-writer k val port)
(if (or (string-index val #\;)
(write-qstring val port)
(display val port)))
-(define* (parse-key-value-list str #:optional (kproc identity)
- (kons default-kons)
+(define* (parse-key-value-list str #:optional
+ (val-parser default-val-parser)
(start 0) (end (string-length str)))
(let lp ((i start) (out '()))
(if (not (< i end))
(eq (string-index str #\= i end))
(comma (string-index str #\, i end))
(delim (min (or eq end) (or comma end)))
- (k (kproc (substring str i (trim-whitespace str i delim)))))
+ (k (string->symbol
+ (substring str i (trim-whitespace str i delim)))))
(call-with-values
(lambda ()
(if (and eq (or (not comma) (< eq comma)))
(or comma end))))
(values #f delim)))
(lambda (v-str next-i)
- (let ((i (skip-whitespace str next-i end)))
+ (let ((v (val-parser k v-str))
+ (i (skip-whitespace str next-i end)))
(if (or (= i end) (eqv? (string-ref str i) #\,))
- (lp (1+ i) (cons (kons k v-str) out))
+ (lp (1+ i) (cons (if v (cons k v) k) out))
(bad-header-component 'key-value-list
(substring str start end))))))))))
(define* (key-value-list? list #:optional
- (valid? default-kv-validator))
+ (valid? default-val-validator))
(list-of? list
(lambda (elt)
(cond
((pair? elt)
(let ((k (car elt))
(v (cdr elt)))
- (and (or (string? k) (symbol? k))
+ (and (symbol? k)
(valid? k v))))
- ((or (string? elt) (symbol? elt))
+ ((symbol? elt)
(valid? elt #f))
(else #f)))))
;; param-component = token [ "=" (token | quoted-string) ] \
;; *(";" token [ "=" (token | quoted-string) ])
;;
-(define* (parse-param-component str #:optional (kproc identity)
- (kons default-kons)
+(define* (parse-param-component str #:optional
+ (val-parser default-val-parser)
(start 0) (end (string-length str)))
(let lp ((i start) (out '()))
(if (not (< i end))
(let ((delim (string-index str
(lambda (c) (memq c '(#\, #\; #\=)))
i)))
- (let ((k (kproc
+ (let ((k (string->symbol
(substring str i (trim-whitespace str i (or delim end)))))
(delimc (and delim (string-ref str delim))))
(case delimc
(values (substring str i delim)
delim)))))
(lambda (v-str next-i)
- (let ((x (kons k v-str))
- (i (skip-whitespace str next-i end)))
+ (let* ((v (val-parser k v-str))
+ (x (if v (cons k v) k))
+ (i (skip-whitespace str next-i end)))
(case (and (< i end) (string-ref str i))
((#f)
(values (reverse! (cons x out)) end))
(else ; including #\,
(values (reverse! (cons x out)) i)))))))
((#\;)
- (lp (skip-whitespace str (1+ delim) end)
- (cons (kons k #f) out)))
+ (let ((v (val-parser k #f)))
+ (lp (skip-whitespace str (1+ delim) end)
+ (cons (if v (cons k v) k) out))))
(else ;; either the end of the string or a #\,
- (values (reverse! (cons (kons k #f) out))
- (or delim end)))))))))
+ (let ((v (val-parser k #f)))
+ (values (reverse! (cons (if v (cons k v) k) out))
+ (or delim end))))))))))
(define* (parse-param-list str #:optional
- (kproc identity) (kons default-kons)
+ (val-parser default-val-parser)
(start 0) (end (string-length str)))
(let lp ((i start) (out '()))
(call-with-values
- (lambda () (parse-param-component str kproc kons i end))
+ (lambda () (parse-param-component str val-parser i end))
(lambda (item i)
(if (< i end)
(if (eqv? (string-ref str i) #\,)
(reverse! (cons item out)))))))
(define* (validate-param-list list #:optional
- (valid? default-kv-validator))
+ (valid? default-val-validator))
(list-of? list
(lambda (elt)
- (key-value-list? list valid?))))
+ (key-value-list? elt valid?))))
(define* (write-param-list list port #:optional
(val-writer default-val-writer))
(write-key-value-list item port val-writer ";"))
","))
-(define (list-of-strings? val)
- (list-of? val string?))
-
-(define (write-list-of-strings val port)
- (write-list val port display ", "))
+(define-syntax string-match?
+ (lambda (x)
+ (syntax-case x ()
+ ((_ str pat) (string? (syntax->datum #'pat))
+ (let ((p (syntax->datum #'pat)))
+ #`(let ((s str))
+ (and
+ (= (string-length s) #,(string-length p))
+ #,@(let lp ((i 0) (tests '()))
+ (if (< i (string-length p))
+ (let ((c (string-ref p i)))
+ (lp (1+ i)
+ (case c
+ ((#\.) ; Whatever.
+ tests)
+ ((#\d) ; Digit.
+ (cons #`(char-numeric? (string-ref s #,i))
+ tests))
+ ((#\a) ; Alphabetic.
+ (cons #`(char-alphabetic? (string-ref s #,i))
+ tests))
+ (else ; Literal.
+ (cons #`(eqv? (string-ref s #,i) #,c)
+ tests)))))
+ tests)))))))))
+
+;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun"
+;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"
+
+(define (parse-month str start end)
+ (define (bad)
+ (bad-header-component 'month (substring str start end)))
+ (if (not (= (- end start) 3))
+ (bad)
+ (let ((a (string-ref str (+ start 0)))
+ (b (string-ref str (+ start 1)))
+ (c (string-ref str (+ start 2))))
+ (case a
+ ((#\J)
+ (case b
+ ((#\a) (case c ((#\n) 1) (else (bad))))
+ ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad))))
+ (else (bad))))
+ ((#\F)
+ (case b
+ ((#\e) (case c ((#\b) 2) (else (bad))))
+ (else (bad))))
+ ((#\M)
+ (case b
+ ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad))))
+ (else (bad))))
+ ((#\A)
+ (case b
+ ((#\p) (case c ((#\r) 4) (else (bad))))
+ ((#\u) (case c ((#\g) 8) (else (bad))))
+ (else (bad))))
+ ((#\S)
+ (case b
+ ((#\e) (case c ((#\p) 9) (else (bad))))
+ (else (bad))))
+ ((#\O)
+ (case b
+ ((#\c) (case c ((#\t) 10) (else (bad))))
+ (else (bad))))
+ ((#\N)
+ (case b
+ ((#\o) (case c ((#\v) 11) (else (bad))))
+ (else (bad))))
+ ((#\D)
+ (case b
+ ((#\e) (case c ((#\c) 12) (else (bad))))
+ (else (bad))))
+ (else (bad))))))
+
+;; RFC 822, updated by RFC 1123
+;;
+;; Sun, 06 Nov 1994 08:49:37 GMT
+;; 01234567890123456789012345678
+;; 0 1 2
+(define (parse-rfc-822-date str)
+ ;; We could verify the day of the week but we don't.
+ (cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT")
+ (let ((date (parse-non-negative-integer str 5 7))
+ (month (parse-month str 8 11))
+ (year (parse-non-negative-integer str 12 16))
+ (hour (parse-non-negative-integer str 17 19))
+ (minute (parse-non-negative-integer str 20 22))
+ (second (parse-non-negative-integer str 23 25)))
+ (make-date 0 second minute hour date month year 0)))
+ ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT")
+ (let ((date (parse-non-negative-integer str 5 6))
+ (month (parse-month str 7 10))
+ (year (parse-non-negative-integer str 11 15))
+ (hour (parse-non-negative-integer str 16 18))
+ (minute (parse-non-negative-integer str 19 21))
+ (second (parse-non-negative-integer str 22 24)))
+ (make-date 0 second minute hour date month year 0)))
+ (else
+ (bad-header 'date str) ; prevent tail call
+ #f)))
+
+;; RFC 850, updated by RFC 1036
+;; Sunday, 06-Nov-94 08:49:37 GMT
+;; 0123456789012345678901
+;; 0 1 2
+(define (parse-rfc-850-date str comma)
+ ;; We could verify the day of the week but we don't.
+ (let ((tail (substring str (1+ comma))))
+ (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT"))
+ (bad-header 'date str))
+ (let ((date (parse-non-negative-integer tail 1 3))
+ (month (parse-month tail 4 7))
+ (year (parse-non-negative-integer tail 8 10))
+ (hour (parse-non-negative-integer tail 11 13))
+ (minute (parse-non-negative-integer tail 14 16))
+ (second (parse-non-negative-integer tail 17 19)))
+ (make-date 0 second minute hour date month
+ (let* ((now (date-year (current-date)))
+ (then (+ now year (- (modulo now 100)))))
+ (cond ((< (+ then 50) now) (+ then 100))
+ ((< (+ now 50) then) (- then 100))
+ (else then)))
+ 0))))
+
+;; ANSI C's asctime() format
+;; Sun Nov 6 08:49:37 1994
+;; 012345678901234567890123
+;; 0 1 2
+(define (parse-asctime-date str)
+ (if (not (string-match? str "aaa aaa .d dd:dd:dd dddd"))
+ (bad-header 'date str))
+ (let ((date (parse-non-negative-integer
+ str
+ (if (eqv? (string-ref str 8) #\space) 9 8)
+ 10))
+ (month (parse-month str 4 7))
+ (year (parse-non-negative-integer str 20 24))
+ (hour (parse-non-negative-integer str 11 13))
+ (minute (parse-non-negative-integer str 14 16))
+ (second (parse-non-negative-integer str 17 19)))
+ (make-date 0 second minute hour date month year 0)))
(define (parse-date str)
- ;; Unfortunately, there is no way to make string->date parse out the
- ;; "GMT" bit, so we play string games to append a format it will
- ;; understand (the +0000 bit).
- (string->date
- (if (string-suffix? " GMT" str)
- (string-append (substring str 0 (- (string-length str) 4))
- " +0000")
- (bad-header-component 'date str))
- "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (if (string-suffix? " GMT" str)
+ (let ((comma (string-index str #\,)))
+ (cond ((not comma) (bad-header 'date str))
+ ((= comma 3) (parse-rfc-822-date str))
+ (else (parse-rfc-850-date str comma))))
+ (parse-asctime-date str)))
(define (write-date date port)
- (display (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT") port))
-
-(define (write-uri uri port)
- (display (unparse-uri uri) port))
+ (define (display-digits n digits port)
+ (define zero (char->integer #\0))
+ (let lp ((tens (expt 10 (1- digits))))
+ (if (> tens 0)
+ (begin
+ (display (integer->char (+ zero (modulo (truncate/ n tens) 10)))
+ port)
+ (lp (floor/ tens 10))))))
+ (let ((date (if (zero? (date-zone-offset date))
+ date
+ (time-tai->date (date->time-tai date) 0))))
+ (display (case (date-week-day date)
+ ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ")
+ ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ")
+ ((6) "Sat, ") (else (error "bad date" date)))
+ port)
+ (display-digits (date-day date) 2 port)
+ (display (case (date-month date)
+ ((1) " Jan ") ((2) " Feb ") ((3) " Mar ")
+ ((4) " Apr ") ((5) " May ") ((6) " Jun ")
+ ((7) " Jul ") ((8) " Aug ") ((9) " Sep ")
+ ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
+ (else (error "bad date" date)))
+ port)
+ (display-digits (date-year date) 4 port)
+ (display #\space port)
+ (display-digits (date-hour date) 2 port)
+ (display #\: port)
+ (display-digits (date-minute date) 2 port)
+ (display #\: port)
+ (display-digits (date-second date) 2 port)
+ (display " GMT" port)))
(define (parse-entity-tag val)
(if (string-prefix? "W/" val)
(string? (car val))))
(define (write-entity-tag val port)
- (if (cdr val)
+ (if (not (cdr val))
(display "W/" port))
(write-qstring (car val) port))
(define (write-entity-tag-list val port)
(write-list val port write-entity-tag ", "))
+;; credentials = auth-scheme #auth-param
+;; auth-scheme = token
+;; auth-param = token "=" ( token | quoted-string )
+;;
+;; That's what the spec says. In reality the Basic scheme doesn't have
+;; k-v pairs, just one auth token, so we give that token as a string.
+;;
+(define* (parse-credentials str #:optional (val-parser default-val-parser)
+ (start 0) (end (string-length str)))
+ (let* ((start (skip-whitespace str start end))
+ (delim (or (string-index str char-whitespace? start end) end)))
+ (if (= start end)
+ (bad-header-component 'authorization str))
+ (let ((scheme (string->symbol
+ (string-downcase (substring str start (or delim end))))))
+ (case scheme
+ ((basic)
+ (let* ((start (skip-whitespace str delim end)))
+ (if (< start end)
+ (cons scheme (substring str start end))
+ (bad-header-component 'credentials str))))
+ (else
+ (cons scheme (parse-key-value-list str default-val-parser delim end)))))))
+
+(define (validate-credentials val)
+ (and (pair? val) (symbol? (car val))
+ (case (car val)
+ ((basic) (string? (cdr val)))
+ (else (key-value-list? (cdr val))))))
+
+(define (write-credentials val port)
+ (display (car val) port)
+ (if (pair? (cdr val))
+ (begin
+ (display #\space port)
+ (write-key-value-list (cdr val) port))))
+
+;; challenges = 1#challenge
+;; challenge = auth-scheme 1*SP 1#auth-param
+;;
+;; A pain to parse, as both challenges and auth params are delimited by
+;; commas, and qstrings can contain anything. We rely on auth params
+;; necessarily having "=" in them.
+;;
+(define* (parse-challenge str #:optional
+ (start 0) (end (string-length str)))
+ (let* ((start (skip-whitespace str start end))
+ (sp (string-index str #\space start end))
+ (scheme (if sp
+ (string->symbol (string-downcase (substring str start sp)))
+ (bad-header-component 'challenge str))))
+ (let lp ((i sp) (out (list scheme)))
+ (if (not (< i end))
+ (values (reverse! out) end)
+ (let* ((i (skip-whitespace str i end))
+ (eq (string-index str #\= i end))
+ (comma (string-index str #\, i end))
+ (delim (min (or eq end) (or comma end)))
+ (token-end (trim-whitespace str i delim)))
+ (if (string-index str #\space i token-end)
+ (values (reverse! out) i)
+ (let ((k (string->symbol (substring str i token-end))))
+ (call-with-values
+ (lambda ()
+ (if (and eq (or (not comma) (< eq comma)))
+ (let ((i (skip-whitespace str (1+ eq) end)))
+ (if (and (< i end) (eqv? (string-ref str i) #\"))
+ (parse-qstring str i end #:incremental? #t)
+ (values (substring
+ str i
+ (trim-whitespace str i
+ (or comma end)))
+ (or comma end))))
+ (values #f delim)))
+ (lambda (v next-i)
+ (let ((i (skip-whitespace str next-i end)))
+ (if (or (= i end) (eqv? (string-ref str i) #\,))
+ (lp (1+ i) (cons (if v (cons k v) k) out))
+ (bad-header-component
+ 'challenge
+ (substring str start end)))))))))))))
+
+(define* (parse-challenges str #:optional (val-parser default-val-parser)
+ (start 0) (end (string-length str)))
+ (let lp ((i start) (ret '()))
+ (let ((i (skip-whitespace str i end)))
+ (if (< i end)
+ (call-with-values (lambda () (parse-challenge str i end))
+ (lambda (challenge i)
+ (lp i (cons challenge ret))))
+ (reverse ret)))))
+
+(define (validate-challenges val)
+ (list-of? val (lambda (x)
+ (and (pair? x) (symbol? (car x))
+ (key-value-list? (cdr x))))))
+
+(define (write-challenge val port)
+ (display (car val) port)
+ (display #\space port)
+ (write-key-value-list (cdr val) port))
+
+(define (write-challenges val port)
+ (write-list val port write-challenge ", "))
+
\f
(define *known-versions* '())
(define* (parse-http-version str #:optional (start 0) (end (string-length str)))
+ "Parse an HTTP version from @var{str}, returning it as a major-minor
+pair. For example, @code{HTTP/1.1} parses as the pair of integers,
+@code{(1 . 1)}."
(or (let lp ((known *known-versions*))
(and (pair? known)
(if (string= str (caar known) start end)
(bad-header-component 'http-version (substring str start end))))))
(define (write-http-version val port)
+ "Write the given major-minor version pair to @var{port}."
(display "HTTP/" port)
(display (car val) port)
(display #\. port)
;; ourselves the trouble of that case, and disallow the CONNECT method.
;;
(define* (parse-http-method str #:optional (start 0) (end (string-length str)))
+ "Parse an HTTP method from @var{str}. The result is an upper-case
+symbol, like @code{GET}."
(cond
((string= str "GET" start end) 'GET)
((string= str "HEAD" start end) 'HEAD)
(else (bad-request "Invalid method: ~a" (substring str start end)))))
(define* (parse-request-uri str #:optional (start 0) (end (string-length str)))
+ "Parse a URI from an HTTP request line. Note that URIs in requests do
+not have to have a scheme or host name. The result is a URI object."
(cond
((= start end)
(bad-request "Missing Request-URI"))
#:query (and q (substring str (1+ q) (or f end)))
#:fragment (and f (substring str (1+ f) end)))))
(else
- (or (parse-uri (substring str start end))
+ (or (string->uri (substring str start end))
(bad-request "Invalid URI: ~a" (substring str start end))))))
(define (read-request-line port)
+ "Read the first line of an HTTP request from @var{port}, returning
+three values: the method, the URI, and the version."
(let* ((line (read-line* port))
(d0 (string-index line char-whitespace?)) ; "delimiter zero"
(d1 (string-rindex line char-whitespace?)))
(display (uri-query uri) port))))
(define (write-request-line method uri version port)
+ "Write the first line of an HTTP request to @var{port}."
(display method port)
(display #\space port)
- (write-uri uri port)
+ (let ((path (uri-path uri))
+ (query (uri-query uri)))
+ (if (not (string-null? path))
+ (display path port))
+ (if query
+ (begin
+ (display "?" port)
+ (display query port)))
+ (if (and (string-null? path)
+ (not query))
+ ;; Make sure we display something.
+ (display "/" port)))
(display #\space port)
(write-http-version version port)
(display "\r\n" port))
(define (read-response-line port)
+ "Read the first line of an HTTP response from @var{port}, returning
+three values: the HTTP version, the response code, and the \"reason
+phrase\"."
(let* ((line (read-line* port))
(d0 (string-index line char-whitespace?)) ; "delimiter zero"
(d1 (and d0 (string-index line char-whitespace?
(bad-response "Bad Response-Line: ~s" line))))
(define (write-response-line version code reason-phrase port)
+ "Write the first line of an HTTP response to @var{port}."
(write-http-version version port)
(display #\space port)
(display code port)
\f
;;;
-;;; Syntax for declaring headers
+;;; Helpers for declaring headers
;;;
-;; emacs: (put 'declare-header 'scheme-indent-function 1)
-(define-syntax declare-header
- (syntax-rules ()
- ((_ sym name parser validator writer arg ...)
- (declare-header!
- 'sym name
- #:parser parser #:validator validator #:writer writer
- arg ...))))
-
-;; emacs: (put 'declare-opaque-header 'scheme-indent-function 1)
-(define-syntax declare-opaque-header
- (syntax-rules ()
- ((_ sym name)
- (declare-header sym
- name
- parse-opaque-string validate-opaque-string write-opaque-string))))
-
-;; emacs: (put 'declare-date-header 'scheme-indent-function 1)
-(define-syntax declare-date-header
- (syntax-rules ()
- ((_ sym name)
- (declare-header sym
- name
- parse-date date? write-date))))
-
-;; emacs: (put 'declare-string-list-header 'scheme-indent-function 1)
-(define-syntax declare-string-list-header
- (syntax-rules ()
- ((_ sym name)
- (declare-header sym
- name
- split-and-trim list-of-strings? write-list-of-strings))))
-
-;; emacs: (put 'declare-integer-header 'scheme-indent-function 1)
-(define-syntax declare-integer-header
- (syntax-rules ()
- ((_ sym name)
- (declare-header sym
- name
- parse-non-negative-integer non-negative-integer? display))))
-
-;; emacs: (put 'declare-uri-header 'scheme-indent-function 1)
-(define-syntax declare-uri-header
- (syntax-rules ()
- ((_ sym name)
- (declare-header sym
- name
- (lambda (str) (or (parse-uri str) (bad-header-component 'uri str)))
- uri?
- write-uri))))
-
-;; emacs: (put 'declare-quality-list-header 'scheme-indent-function 1)
-(define-syntax declare-quality-list-header
- (syntax-rules ()
- ((_ sym name)
- (declare-header sym
- name
- parse-quality-list validate-quality-list write-quality-list))))
-
-;; emacs: (put 'declare-param-list-header 'scheme-indent-function 1)
-(define-syntax declare-param-list-header
- (syntax-rules ()
- ((_ sym name)
- (declare-param-list-header sym name identity default-kons
- default-kv-validator default-val-writer))
- ((_ sym name kproc)
- (declare-param-list-header sym name kproc default-kons
- default-kv-validator default-val-writer))
- ((_ sym name kproc kons val-validator val-writer)
- (declare-header sym
- name
- (lambda (str) (parse-param-list str kproc kons))
- (lambda (val) (validate-param-list val val-validator))
- (lambda (val port) (write-param-list val port val-writer))))))
-
-;; emacs: (put 'declare-key-value-list-header 'scheme-indent-function 1)
-(define-syntax declare-key-value-list-header
- (syntax-rules ()
- ((_ sym name)
- (declare-key-value-list-header sym name identity default-kons
- default-kv-validator default-val-writer))
- ((_ sym name kproc)
- (declare-key-value-list-header sym name kproc default-kons
- default-kv-validator default-val-writer))
- ((_ sym name kproc kons val-validator val-writer)
- (declare-header sym
- name
- (lambda (str) (parse-key-value-list str kproc kons))
- (lambda (val) (key-value-list? val val-validator))
- (lambda (val port) (write-key-value-list val port val-writer))))))
-
-;; emacs: (put 'declare-entity-tag-list-header 'scheme-indent-function 1)
-(define-syntax declare-entity-tag-list-header
- (syntax-rules ()
- ((_ sym name)
- (declare-header sym
- name
- (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str)))
- (lambda (val) (or (eq? val '*) (entity-tag-list? val)))
- (lambda (val port)
- (if (eq? val '*)
- (display "*" port)
- (write-entity-tag-list val port)))))))
+;; emacs: (put 'declare-header! 'scheme-indent-function 1)
+;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
+(define (declare-opaque-header! name)
+ (declare-header! name
+ parse-opaque-string validate-opaque-string write-opaque-string))
+
+;; emacs: (put 'declare-date-header! 'scheme-indent-function 1)
+(define (declare-date-header! name)
+ (declare-header! name
+ parse-date date? write-date))
+
+;; emacs: (put 'declare-string-list-header! 'scheme-indent-function 1)
+(define (declare-string-list-header! name)
+ (declare-header! name
+ split-and-trim list-of-strings? write-list-of-strings))
+
+;; emacs: (put 'declare-symbol-list-header! 'scheme-indent-function 1)
+(define (declare-symbol-list-header! name)
+ (declare-header! name
+ (lambda (str)
+ (map string->symbol (split-and-trim str)))
+ (lambda (v)
+ (list-of? v symbol?))
+ (lambda (v port)
+ (write-list v port display ", "))))
+
+;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1)
+(define (declare-header-list-header! name)
+ (declare-header! name
+ split-header-names list-of-header-names? write-header-list))
+
+;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1)
+(define (declare-integer-header! name)
+ (declare-header! name
+ parse-non-negative-integer non-negative-integer? display))
+
+;; emacs: (put 'declare-uri-header! 'scheme-indent-function 1)
+(define (declare-uri-header! name)
+ (declare-header! name
+ (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
+ uri?
+ write-uri))
+
+;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1)
+(define (declare-quality-list-header! name)
+ (declare-header! name
+ parse-quality-list validate-quality-list write-quality-list))
+
+;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1)
+(define* (declare-param-list-header! name #:optional
+ (val-parser default-val-parser)
+ (val-validator default-val-validator)
+ (val-writer default-val-writer))
+ (declare-header! name
+ (lambda (str) (parse-param-list str val-parser))
+ (lambda (val) (validate-param-list val val-validator))
+ (lambda (val port) (write-param-list val port val-writer))))
+
+;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1)
+(define* (declare-key-value-list-header! name #:optional
+ (val-parser default-val-parser)
+ (val-validator default-val-validator)
+ (val-writer default-val-writer))
+ (declare-header! name
+ (lambda (str) (parse-key-value-list str val-parser))
+ (lambda (val) (key-value-list? val val-validator))
+ (lambda (val port) (write-key-value-list val port val-writer))))
+
+;; emacs: (put 'declare-entity-tag-list-header! 'scheme-indent-function 1)
+(define (declare-entity-tag-list-header! name)
+ (declare-header! name
+ (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str)))
+ (lambda (val) (or (eq? val '*) (entity-tag-list? val)))
+ (lambda (val port)
+ (if (eq? val '*)
+ (display "*" port)
+ (write-entity-tag-list val port)))))
+
+;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1)
+(define (declare-credentials-header! name)
+ (declare-header! name
+ parse-credentials validate-credentials write-credentials))
+
+;; emacs: (put 'declare-challenge-list-header! 'scheme-indent-function 1)
+(define (declare-challenge-list-header! name)
+ (declare-header! name
+ parse-challenges validate-challenges write-challenges))
\f
;; | cache-extension ; Section 14.9.6
;; cache-extension = token [ "=" ( token | quoted-string ) ]
;;
-(declare-key-value-list-header cache-control
- "Cache-Control"
- (let ((known-directives (make-hash-table)))
- (for-each (lambda (s)
- (hash-set! known-directives s (string->symbol s)))
- '("no-cache" "no-store" "max-age" "max-stale" "min-fresh"
- "no-transform" "only-if-cached" "public" "private"
- "must-revalidate" "proxy-revalidate" "s-maxage"))
- (lambda (k-str)
- (hash-ref known-directives k-str k-str)))
+(declare-key-value-list-header! "Cache-Control"
(lambda (k v-str)
(case k
- ((max-age max-stale min-fresh s-maxage)
- (cons k (parse-non-negative-integer v-str)))
+ ((max-age min-fresh s-maxage)
+ (parse-non-negative-integer v-str))
+ ((max-stale)
+ (and v-str (parse-non-negative-integer v-str)))
((private no-cache)
- (cons k (if v-str (split-and-trim v-str) #t)))
- (else (if v-str (cons k v-str) k))))
- default-kv-validator
+ (and v-str (split-header-names v-str)))
+ (else v-str)))
+ (lambda (k v)
+ (case k
+ ((max-age min-fresh s-maxage)
+ (non-negative-integer? v))
+ ((max-stale)
+ (or (not v) (non-negative-integer? v)))
+ ((private no-cache)
+ (or (not v) (list-of-header-names? v)))
+ ((no-store no-transform only-if-cache must-revalidate proxy-revalidate)
+ (not v))
+ (else
+ (or (not v) (string? v)))))
(lambda (k v port)
(cond
- ((string? v) (display v port))
+ ((string? v) (default-val-writer k v port))
((pair? v)
- (write-qstring (string-join v ", ") port))
+ (display #\" port)
+ (write-header-list v port)
+ (display #\" port))
((integer? v)
(display v port))
(else
;; e.g.
;; Connection: close, foo-header
;;
-(declare-string-list-header connection
- "Connection")
+(declare-header-list-header! "Connection")
;; Date = "Date" ":" HTTP-date
;; e.g.
;; Date: Tue, 15 Nov 1994 08:12:31 GMT
;;
-(declare-date-header date
- "Date")
+(declare-date-header! "Date")
;; Pragma = "Pragma" ":" 1#pragma-directive
;; pragma-directive = "no-cache" | extension-pragma
;; extension-pragma = token [ "=" ( token | quoted-string ) ]
;;
-(declare-key-value-list-header pragma
- "Pragma"
- (lambda (k) (if (equal? k "no-cache") 'no-cache k)))
+(declare-key-value-list-header! "Pragma")
;; Trailer = "Trailer" ":" 1#field-name
;;
-(declare-string-list-header trailer
- "Trailer")
+(declare-header-list-header! "Trailer")
;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding
;;
-(declare-param-list-header transfer-encoding
- "Transfer-Encoding"
- (lambda (k)
- (if (equal? k "chunked") 'chunked k)))
+(declare-param-list-header! "Transfer-Encoding")
;; Upgrade = "Upgrade" ":" 1#product
;;
-(declare-string-list-header upgrade
- "Upgrade")
+(declare-string-list-header! "Upgrade")
;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] )
;; received-protocol = [ protocol-name "/" ] protocol-version
;; received-by = ( host [ ":" port ] ) | pseudonym
;; pseudonym = token
;;
-(declare-header via
- "Via"
+(declare-header! "Via"
split-and-trim
list-of-strings?
write-list-of-strings
;; ; the Warning header, for use in debugging
;; warn-text = quoted-string
;; warn-date = <"> HTTP-date <">
-(declare-header warning
- "Warning"
+(declare-header! "Warning"
(lambda (str)
(let ((len (string-length str)))
(let lp ((i (skip-whitespace str 0)))
;; Allow = #Method
;;
-(declare-string-list-header allow
- "Allow")
+(declare-symbol-list-header! "Allow")
;; Content-Encoding = 1#content-coding
;;
-(declare-string-list-header content-encoding
- "Content-Encoding")
+(declare-symbol-list-header! "Content-Encoding")
;; Content-Language = 1#language-tag
;;
-(declare-string-list-header content-language
- "Content-Language")
+(declare-string-list-header! "Content-Language")
;; Content-Length = 1*DIGIT
;;
-(declare-integer-header content-length
- "Content-Length")
+(declare-integer-header! "Content-Length")
;; Content-Location = ( absoluteURI | relativeURI )
;;
-(declare-uri-header content-location
- "Content-Location")
+(declare-uri-header! "Content-Location")
;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
;;
-(declare-opaque-header content-md5
- "Content-MD5")
+(declare-opaque-header! "Content-MD5")
;; Content-Range = content-range-spec
;; content-range-spec = byte-content-range-spec
;; | "*"
;; instance-length = 1*DIGIT
;;
-(declare-header content-range
- "Content-Range"
+(declare-header! "Content-Range"
(lambda (str)
(let ((dash (string-index str #\-))
(slash (string-index str #\/)))
;; Content-Type = media-type
;;
-(declare-header content-type
- "Content-Type"
+(declare-header! "Content-Type"
(lambda (str)
(let ((parts (string-split str #\;)))
- (call-with-values (lambda () (parse-media-type (car parts)))
- (lambda (type subtype)
- (cons* type subtype
- (map (lambda (x)
- (let ((eq (string-index x #\=)))
- (if (and eq (= eq (string-rindex x #\=)))
- (cons (string-trim x 0 eq)
- (string-trim-right x (1+ eq)))
- (bad-header 'content-type str))))
- (cdr parts)))))))
+ (cons (parse-media-type (car parts))
+ (map (lambda (x)
+ (let ((eq (string-index x #\=)))
+ (if (and eq (= eq (string-rindex x #\=)))
+ (cons (string->symbol
+ (string-trim x char-whitespace? 0 eq))
+ (string-trim-right x char-whitespace? (1+ eq)))
+ (bad-header 'content-type str))))
+ (cdr parts)))))
(lambda (val)
- (and (list-of? val string?)
- (let ((len (length val)))
- (and (>= len 2)
- (even? len)))))
+ (and (pair? val)
+ (symbol? (car val))
+ (list-of? (cdr val)
+ (lambda (x)
+ (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
(lambda (val port)
(display (car val) port)
- (display #\/ port)
- (display (cadr val) port)
- (write-list
- (cddr val) port
- (lambda (pair port)
- (display (car pair) port)
- (display #\= port)
- (display (cdr pair) port))
- ";")))
+ (if (pair? (cdr val))
+ (begin
+ (display ";" port)
+ (write-list
+ (cdr val) port
+ (lambda (pair port)
+ (display (car pair) port)
+ (display #\= port)
+ (display (cdr pair) port))
+ ";")))))
;; Expires = HTTP-date
;;
-(declare-date-header expires
- "Expires")
+(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT"))
+
+(declare-header! "Expires"
+ (lambda (str)
+ (if (member str '("0" "-1"))
+ *date-in-the-past*
+ (parse-date str)))
+ date?
+ write-date)
;; Last-Modified = HTTP-date
;;
-(declare-date-header last-modified
- "Last-Modified")
+(declare-date-header! "Last-Modified")
\f
;; accept-params = ";" "q" "=" qvalue *( accept-extension )
;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
;;
-(declare-param-list-header accept
- "Accept"
- ;; -> ("type/subtype" (str-prop . str-val) ...) ...)
+(declare-param-list-header! "Accept"
+ ;; -> (type/subtype (sym-prop . str-val) ...) ...)
;;
- ;; with the exception of prop = "q", in which case the prop will be
- ;; the symbol 'q, and the val will be a valid quality value
+ ;; with the exception of prop `q', in which case the val will be a
+ ;; valid quality value
;;
- (lambda (k) (if (string=? k "q") 'q k))
(lambda (k v)
- (if (eq? k 'q)
- (cons k (parse-quality v))
- (default-kons k v)))
+ (if (eq? k 'q)
+ (parse-quality v)
+ v))
(lambda (k v)
(if (eq? k 'q)
(valid-quality? v)
- (default-kv-validator k v)))
+ (or (not v) (string? v))))
(lambda (k v port)
(if (eq? k 'q)
(write-quality v port)
;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] )
;;
-(declare-quality-list-header accept-charset
- "Accept-Charset")
+(declare-quality-list-header! "Accept-Charset")
;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] )
;; codings = ( content-coding | "*" )
;;
-(declare-quality-list-header accept-encoding
- "Accept-Encoding")
+(declare-quality-list-header! "Accept-Encoding")
;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] )
;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )
;;
-(declare-quality-list-header accept-language
- "Accept-Language")
+(declare-quality-list-header! "Accept-Language")
;; Authorization = credentials
+;; credentials = auth-scheme #auth-param
+;; auth-scheme = token
+;; auth-param = token "=" ( token | quoted-string )
;;
-;; Authorization is basically opaque to this HTTP stack, we just pass
-;; the string value through.
-;;
-(declare-opaque-header authorization
- "Authorization")
+(declare-credentials-header! "Authorization")
;; Expect = 1#expectation
;; expectation = "100-continue" | expectation-extension
;; *expect-params ]
;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
;;
-(declare-param-list-header expect
- "Expect"
- (lambda (k)
- (if (equal? k "100-continue")
- '100-continue
- k)))
+(declare-param-list-header! "Expect")
;; From = mailbox
;;
;; Should be an email address; we just pass on the string as-is.
;;
-(declare-opaque-header from
- "From")
+(declare-opaque-header! "From")
;; Host = host [ ":" port ]
;;
-(declare-header host
- "Host"
+(declare-header! "Host"
(lambda (str)
(let ((colon (string-index str #\:)))
(if colon
;; If-Match = ( "*" | 1#entity-tag )
;;
-(declare-entity-tag-list-header if-match
- "If-Match")
+(declare-entity-tag-list-header! "If-Match")
;; If-Modified-Since = HTTP-date
;;
-(declare-date-header if-modified-since
- "If-Modified-Since")
+(declare-date-header! "If-Modified-Since")
;; If-None-Match = ( "*" | 1#entity-tag )
;;
-(declare-entity-tag-list-header if-none-match
- "If-None-Match")
+(declare-entity-tag-list-header! "If-None-Match")
;; If-Range = ( entity-tag | HTTP-date )
;;
-(declare-header if-range
- "If-Range"
+(declare-header! "If-Range"
(lambda (str)
(if (or (string-prefix? "\"" str)
(string-prefix? "W/" str))
;; If-Unmodified-Since = HTTP-date
;;
-(declare-date-header if-unmodified-since
- "If-Unmodified-Since")
+(declare-date-header! "If-Unmodified-Since")
;; Max-Forwards = 1*DIGIT
;;
-(declare-integer-header max-forwards
- "Max-Forwards")
+(declare-integer-header! "Max-Forwards")
;; Proxy-Authorization = credentials
;;
-(declare-opaque-header proxy-authorization
- "Proxy-Authorization")
+(declare-credentials-header! "Proxy-Authorization")
;; Range = "Range" ":" ranges-specifier
;; ranges-specifier = byte-ranges-specifier
;; suffix-byte-range-spec = "-" suffix-length
;; suffix-length = 1*DIGIT
;;
-(declare-header range
- "Range"
+(declare-header! "Range"
(lambda (str)
(if (string-prefix? "bytes=" str)
(cons
;; Referer = ( absoluteURI | relativeURI )
;;
-(declare-uri-header referer
- "Referer")
+(declare-uri-header! "Referer")
;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
;;
-(declare-param-list-header te
- "TE"
- (lambda (k) (if (equal? k "trailers") 'trailers k)))
+(declare-param-list-header! "TE")
;; User-Agent = 1*( product | comment )
;;
-(declare-opaque-header user-agent
- "User-Agent")
+(declare-opaque-header! "User-Agent")
\f
;; Accept-Ranges = acceptable-ranges
;; acceptable-ranges = 1#range-unit | "none"
;;
-(declare-string-list-header accept-ranges
- "Accept-Ranges")
+(declare-symbol-list-header! "Accept-Ranges")
;; Age = age-value
;; age-value = delta-seconds
;;
-(declare-integer-header age
- "Age")
+(declare-integer-header! "Age")
;; ETag = entity-tag
;;
-(declare-header etag
- "ETag"
+(declare-header! "ETag"
parse-entity-tag
entity-tag?
write-entity-tag)
;; Location = absoluteURI
;;
-(declare-uri-header location
- "Location")
+(declare-uri-header! "Location")
;; Proxy-Authenticate = 1#challenge
;;
-;; FIXME: split challenges ?
-(declare-opaque-header proxy-authenticate
- "Proxy-Authenticate")
+(declare-challenge-list-header! "Proxy-Authenticate")
;; Retry-After = ( HTTP-date | delta-seconds )
;;
-(declare-header retry-after
- "Retry-After"
+(declare-header! "Retry-After"
(lambda (str)
(if (and (not (string-null? str))
(char-numeric? (string-ref str 0)))
;; Server = 1*( product | comment )
;;
-(declare-opaque-header server
- "Server")
+(declare-opaque-header! "Server")
;; Vary = ( "*" | 1#field-name )
;;
-(declare-header vary
- "Vary"
+(declare-header! "Vary"
(lambda (str)
(if (equal? str "*")
'*
- (split-and-trim str)))
+ (split-header-names str)))
(lambda (val)
- (or (eq? val '*) (list-of-strings? val)))
+ (or (eq? val '*) (list-of-header-names? val)))
(lambda (val port)
(if (eq? val '*)
(display "*" port)
- (write-list-of-strings val port))))
+ (write-header-list val port))))
;; WWW-Authenticate = 1#challenge
;;
-;; Hum.
-(declare-opaque-header www-authenticate
- "WWW-Authenticate")
+(declare-challenge-list-header! "WWW-Authenticate")
HCoop / bpt / guile.git / blobdiff