mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +02:00
Code Activity

(web http): header names always represented as symbols

Browse source 
* module/web/http.scm (declare-header!): No need to specify `sym', as it
  can be derived from `name'. Change to take parser, validator, and
  writer as positional arguments, and multiple? as a keyword.
  (parse-header): Change to take the header as a symbol already, and
  just return the parsed value.  All headers are symbols now, including
  unknown headers.  I feel OK doing this given that the symbol GC works
  now.
  (lookup-header-decl): Only look up headers by symbol.
  (read-header): Adapt to parse-header change.

  (valid-header?, write-header): Adapt to all headers being symbols.
  (split-header-names, list-of-header-names?, write-header-list):
  Represent all header names as symbols.

  (declare-opaque-header!, declare-date-header!)
  (declare-string-list-header!, declare-header-list-header!)
  (declare-integer-header!, declare-uri-header!)
  (declare-quality-list-header!, declare-param-list-header!)
  (declare-key-value-list-header!, declare-entity-tag-list-header!):
  Change to be functions instead of syntax, and no need to specify the
  symbolic name. Update all header declarations accordingly.

* module/web/request.scm (validate-headers):
* module/web/response.scm (validate-headers): Adapt to all headers being
  symbols.

* test-suite/tests/web-http.test (pass-if-parse, pass-if-any-error)
  (pass-if-parse-error): Update for parse-header change.
  ("general headers"): Update header list examples to be all symbols.
This commit is contained in:
Andy Wingo 2011-01-08 10:54:07 -08:00
parent a574564c24
commit be1be3e597
4 changed files with 178 additions and 289 deletions
Download patch file Download diff file Expand all files Collapse all files

424
module/web/http.scm
View file

@ -1,6 +1,6 @@
;;; HTTP messages ;;; HTTP messages
;; Copyright (C) 2010 Free Software Foundation, Inc. ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -84,27 +84,25 @@
;; sym -> header ;; sym -> header
(define *declared-headers* (make-hash-table)) (define *declared-headers* (make-hash-table))
;; downcased name -> header
(define *declared-headers-by-name* (make-hash-table))
(define* (declare-header! sym name #:key (define* (declare-header! name
multiple?
parser parser
validator validator
writer) writer
#:key multiple?)
"Define a parser, validator, and writer for the HTTP header, @var{name}. "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 @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. @var{validator} is a predicate for whether the given
Scheme value is valid for this header. @var{writer} takes a value and a Scheme value is valid for this header. @var{writer} takes a value and a
port, and writes the value to the port." port, and writes the value to the port."
(if (and (symbol? sym) (string? name) parser validator writer) (if (and (string? name) parser validator writer)
(let ((decl (make-header-decl sym name (let* ((sym (string->symbol (string-downcase name)))
multiple? parser validator writer))) (decl (make-header-decl sym name
multiple? parser validator writer)))
(hashq-set! *declared-headers* sym decl) (hashq-set! *declared-headers* sym decl)
(hash-set! *declared-headers-by-name* (string-downcase name) decl)
decl) decl)
(error "bad header decl" sym name multiple? parser validator writer))) (error "bad header decl" name multiple? parser validator writer)))
(define (read-line* port) (define (read-line* port)
(let* ((pair (%read-line port)) (let* ((pair (%read-line port))
@ -143,63 +141,54 @@ body was reached (i.e., a blank line)."
(if (or (string-null? line) (if (or (string-null? line)
(string=? line "\r")) (string=? line "\r"))
(values *eof* *eof*) (values *eof* *eof*)
(let ((delim (or (string-index line #\:) (let* ((delim (or (string-index line #\:)
(bad-header '%read line)))) (bad-header '%read line)))
(parse-header (sym (string->symbol
(substring line 0 delim) (string-downcase! (substring/copy line 0 delim)))))
(read-continuation-line (values
port sym
(string-trim-both line char-whitespace? (1+ delim)))))))) (parse-header
sym
(read-continuation-line
port
(string-trim-both line char-whitespace? (1+ delim)))))))))
(define (lookup-header-decl name) (define (lookup-header-decl sym)
"Return the @var{header-decl} object registered for the given @var{name}. "Return the @var{header-decl} object registered for the given
@var{sym}, which should be a symbol."
(hashq-ref *declared-headers* sym))
@var{name} may be a symbol or a string. Strings are mapped to headers (define (parse-header sym val)
in a case-insensitive fashion." "Parse @var{val}, a string, with the parser registered for the header
(if (string? name) named @var{sym}.
(hash-ref *declared-headers-by-name* (string-downcase name))
(hashq-ref *declared-headers* name)))
(define (parse-header name val) Returns the parsed value. If a parser was not found, the value is
"Parse @var{val}, a string, with the parser for the header named @var{name}. returned as a string."
(let ((decl (lookup-header-decl sym)))
Returns two values, the header name and parsed value. If a parser was
found, the header name will be returned as a symbol. If a parser was
not found, both the header name and the value are returned as strings."
(let* ((down (string-downcase name))
(decl (hash-ref *declared-headers-by-name* down)))
(if decl (if decl
(values (header-decl-sym decl) ((header-decl-parser decl) val)
((header-decl-parser decl) val)) val)))
(values down val))))
(define (valid-header? sym val) (define (valid-header? sym val)
"Returns a true value iff @var{val} is a valid Scheme value for the "Returns a true value iff @var{val} is a valid Scheme value for the
header with name @var{sym}." header with name @var{sym}."
(let ((decl (hashq-ref *declared-headers* sym))) (if (symbol? sym)
(if (not decl) (let ((decl (lookup-header-decl sym)))
(error "Unknown header" sym) (or (not decl)
((header-decl-validator decl) val)))) ((header-decl-validator decl) val)))
(error "header name not a symbol" sym)))
(define (write-header name val port) (define (write-header sym val port)
"Writes the given header name and value to @var{port}. If @var{name} "Writes the given header name and value to @var{port}. If @var{sym}
is a symbol, looks up a declared header and uses that writer. Otherwise is a known header, uses the specific writer registered for that header.
the value is written using @var{display}." Otherwise the value is written using @var{display}."
(if (string? name) (let ((decl (lookup-header-decl sym)))
;; assume that it's a header we don't know about... (if decl
(begin (display (header-decl-name decl) port)
(display name port) (display (string-titlecase (symbol->string sym)) port))
(display ": " port) (display ": " port)
(display val port) ((if decl (header-decl-writer decl) display) val port)
(display "\r\n" 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))))))
(define (read-headers port) (define (read-headers port)
"Read an HTTP message from @var{port}, returning the headers as an "Read an HTTP message from @var{port}, returning the headers as an
@ -279,20 +268,18 @@ ordered alist."
(define (split-header-names str) (define (split-header-names str)
(map (lambda (f) (map (lambda (f)
(or (and=> (lookup-header-decl f) header-decl-sym) (string->symbol (string-downcase f)))
f))
(split-and-trim str))) (split-and-trim str)))
(define (list-of-header-names? val) (define (list-of-header-names? val)
(list-of? val (lambda (x) (or (string? x) (symbol? x))))) (list-of? val symbol?))
(define (write-header-list val port) (define (write-header-list val port)
(write-list val port (write-list val port
(lambda (x port) (lambda (x port)
(display (or (and (symbol? x) (display (or (and=> (lookup-header-decl x)
(and=> (lookup-header-decl x) header-decl-name)
header-decl-name)) (string-titlecase (symbol->string x)))
x)
port)) port))
", ")) ", "))
@ -834,120 +821,78 @@ phrase\"."
;;; ;;;
;;; Syntax for declaring headers ;;; Helpers for declaring headers
;;; ;;;
;; emacs: (put 'declare-header 'scheme-indent-function 1) ;; emacs: (put 'declare-header! 'scheme-indent-function 1)
(define-syntax declare-header ;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
(syntax-rules () (define (declare-opaque-header! name)
((_ sym name parser validator writer arg ...) (declare-header! name
(declare-header! parse-opaque-string validate-opaque-string write-opaque-string))
'sym name
#:parser parser #:validator validator #:writer writer
arg ...))))
;; emacs: (put 'declare-opaque-header 'scheme-indent-function 1) ;; emacs: (put 'declare-date-header! 'scheme-indent-function 1)
(define-syntax declare-opaque-header (define (declare-date-header! name)
(syntax-rules () (declare-header! name
((_ sym name) parse-date date? write-date))
(declare-header sym
name
parse-opaque-string validate-opaque-string write-opaque-string))))
;; emacs: (put 'declare-date-header 'scheme-indent-function 1) ;; emacs: (put 'declare-string-list-header! 'scheme-indent-function 1)
(define-syntax declare-date-header (define (declare-string-list-header! name)
(syntax-rules () (declare-header! name
((_ sym name) split-and-trim list-of-strings? write-list-of-strings))
(declare-header sym
name
parse-date date? write-date))))
;; emacs: (put 'declare-string-list-header 'scheme-indent-function 1) ;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1)
(define-syntax declare-string-list-header (define (declare-header-list-header! name)
(syntax-rules () (declare-header! name
((_ sym name) split-header-names list-of-header-names? write-header-list))
(declare-header sym
name
split-and-trim list-of-strings? write-list-of-strings))))
;; emacs: (put 'declare-header-list-header 'scheme-indent-function 1) ;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1)
(define-syntax declare-header-list-header (define (declare-integer-header! name)
(syntax-rules () (declare-header! name
((_ sym name) parse-non-negative-integer non-negative-integer? display))
(declare-header sym
name
split-header-names list-of-header-names? write-header-list))))
;; emacs: (put 'declare-integer-header 'scheme-indent-function 1) ;; emacs: (put 'declare-uri-header! 'scheme-indent-function 1)
(define-syntax declare-integer-header (define (declare-uri-header! name)
(syntax-rules () (declare-header! name
((_ sym name) (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
(declare-header sym uri?
name write-uri))
parse-non-negative-integer non-negative-integer? display))))
;; emacs: (put 'declare-uri-header 'scheme-indent-function 1) ;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1)
(define-syntax declare-uri-header (define (declare-quality-list-header! name)
(syntax-rules () (declare-header! name
((_ sym name) parse-quality-list validate-quality-list write-quality-list))
(declare-header sym
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) ;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1)
(define-syntax declare-quality-list-header (define* (declare-param-list-header! name #:optional
(syntax-rules () (kproc identity)
((_ sym name) (kons default-kons)
(declare-header sym (val-validator default-kv-validator)
name (val-writer default-val-writer))
parse-quality-list validate-quality-list write-quality-list)))) (declare-header! 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-param-list-header 'scheme-indent-function 1) ;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1)
(define-syntax declare-param-list-header (define* (declare-key-value-list-header! name #:optional
(syntax-rules () (kproc identity)
((_ sym name) (kons default-kons)
(declare-param-list-header sym name identity default-kons (val-validator default-kv-validator)
default-kv-validator default-val-writer)) (val-writer default-val-writer))
((_ sym name kproc) (declare-header! name
(declare-param-list-header sym name kproc default-kons (lambda (str) (parse-key-value-list str kproc kons))
default-kv-validator default-val-writer)) (lambda (val) (key-value-list? val val-validator))
((_ sym name kproc kons val-validator val-writer) (lambda (val port) (write-key-value-list val port 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) ;; emacs: (put 'declare-entity-tag-list-header! 'scheme-indent-function 1)
(define-syntax declare-key-value-list-header (define (declare-entity-tag-list-header! name)
(syntax-rules () (declare-header! name
((_ sym name) (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str)))
(declare-key-value-list-header sym name identity default-kons (lambda (val) (or (eq? val '*) (entity-tag-list? val)))
default-kv-validator default-val-writer)) (lambda (val port)
((_ sym name kproc) (if (eq? val '*)
(declare-key-value-list-header sym name kproc default-kons (display "*" port)
default-kv-validator default-val-writer)) (write-entity-tag-list val port)))))
((_ 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)))))))
@ -980,8 +925,7 @@ phrase\"."
;; | cache-extension ; Section 14.9.6 ;; | cache-extension ; Section 14.9.6
;; cache-extension = token [ "=" ( token | quoted-string ) ] ;; cache-extension = token [ "=" ( token | quoted-string ) ]
;; ;;
(declare-key-value-list-header cache-control (declare-key-value-list-header! "Cache-Control"
"Cache-Control"
(let ((known-directives (make-hash-table))) (let ((known-directives (make-hash-table)))
(for-each (lambda (s) (for-each (lambda (s)
(hash-set! known-directives s (string->symbol s))) (hash-set! known-directives s (string->symbol s)))
@ -1017,40 +961,34 @@ phrase\"."
;; e.g. ;; e.g.
;; Connection: close, foo-header ;; Connection: close, foo-header
;; ;;
(declare-string-list-header connection (declare-string-list-header! "Connection")
"Connection")
;; Date = "Date" ":" HTTP-date ;; Date = "Date" ":" HTTP-date
;; e.g. ;; e.g.
;; Date: Tue, 15 Nov 1994 08:12:31 GMT ;; Date: Tue, 15 Nov 1994 08:12:31 GMT
;; ;;
(declare-date-header date (declare-date-header! "Date")
"Date")
;; Pragma = "Pragma" ":" 1#pragma-directive ;; Pragma = "Pragma" ":" 1#pragma-directive
;; pragma-directive = "no-cache" | extension-pragma ;; pragma-directive = "no-cache" | extension-pragma
;; extension-pragma = token [ "=" ( token | quoted-string ) ] ;; extension-pragma = token [ "=" ( token | quoted-string ) ]
;; ;;
(declare-key-value-list-header pragma (declare-key-value-list-header! "Pragma"
"Pragma"
(lambda (k) (if (equal? k "no-cache") 'no-cache k))) (lambda (k) (if (equal? k "no-cache") 'no-cache k)))
;; Trailer = "Trailer" ":" 1#field-name ;; Trailer = "Trailer" ":" 1#field-name
;; ;;
(declare-header-list-header trailer (declare-header-list-header! "Trailer")
"Trailer")
;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding ;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding
;; ;;
(declare-param-list-header transfer-encoding (declare-param-list-header! "Transfer-Encoding"
"Transfer-Encoding"
(lambda (k) (lambda (k)
(if (equal? k "chunked") 'chunked k))) (if (equal? k "chunked") 'chunked k)))
;; Upgrade = "Upgrade" ":" 1#product ;; Upgrade = "Upgrade" ":" 1#product
;; ;;
(declare-string-list-header upgrade (declare-string-list-header! "Upgrade")
"Upgrade")
;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] ) ;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] )
;; received-protocol = [ protocol-name "/" ] protocol-version ;; received-protocol = [ protocol-name "/" ] protocol-version
@ -1059,8 +997,7 @@ phrase\"."
;; received-by = ( host [ ":" port ] ) | pseudonym ;; received-by = ( host [ ":" port ] ) | pseudonym
;; pseudonym = token ;; pseudonym = token
;; ;;
(declare-header via (declare-header! "Via"
"Via"
split-and-trim split-and-trim
list-of-strings? list-of-strings?
write-list-of-strings write-list-of-strings
@ -1077,8 +1014,7 @@ phrase\"."
;; ; the Warning header, for use in debugging ;; ; the Warning header, for use in debugging
;; warn-text = quoted-string ;; warn-text = quoted-string
;; warn-date = <"> HTTP-date <"> ;; warn-date = <"> HTTP-date <">
(declare-header warning (declare-header! "Warning"
"Warning"
(lambda (str) (lambda (str)
(let ((len (string-length str))) (let ((len (string-length str)))
(let lp ((i (skip-whitespace str 0))) (let lp ((i (skip-whitespace str 0)))
@ -1149,33 +1085,27 @@ phrase\"."
;; Allow = #Method ;; Allow = #Method
;; ;;
(declare-string-list-header allow (declare-string-list-header! "Allow")
"Allow")
;; Content-Encoding = 1#content-coding ;; Content-Encoding = 1#content-coding
;; ;;
(declare-string-list-header content-encoding (declare-string-list-header! "Content-Encoding")
"Content-Encoding")
;; Content-Language = 1#language-tag ;; Content-Language = 1#language-tag
;; ;;
(declare-string-list-header content-language (declare-string-list-header! "Content-Language")
"Content-Language")
;; Content-Length = 1*DIGIT ;; Content-Length = 1*DIGIT
;; ;;
(declare-integer-header content-length (declare-integer-header! "Content-Length")
"Content-Length")
;; Content-Location = ( absoluteURI | relativeURI ) ;; Content-Location = ( absoluteURI | relativeURI )
;; ;;
(declare-uri-header content-location (declare-uri-header! "Content-Location")
"Content-Location")
;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864> ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
;; ;;
(declare-opaque-header content-md5 (declare-opaque-header! "Content-MD5")
"Content-MD5")
;; Content-Range = content-range-spec ;; Content-Range = content-range-spec
;; content-range-spec = byte-content-range-spec ;; content-range-spec = byte-content-range-spec
@ -1186,8 +1116,7 @@ phrase\"."
;; | "*" ;; | "*"
;; instance-length = 1*DIGIT ;; instance-length = 1*DIGIT
;; ;;
(declare-header content-range (declare-header! "Content-Range"
"Content-Range"
(lambda (str) (lambda (str)
(let ((dash (string-index str #\-)) (let ((dash (string-index str #\-))
(slash (string-index str #\/))) (slash (string-index str #\/)))
@ -1232,8 +1161,7 @@ phrase\"."
;; Content-Type = media-type ;; Content-Type = media-type
;; ;;
(declare-header content-type (declare-header! "Content-Type"
"Content-Type"
(lambda (str) (lambda (str)
(let ((parts (string-split str #\;))) (let ((parts (string-split str #\;)))
(cons (parse-media-type (car parts)) (cons (parse-media-type (car parts))
@ -1265,13 +1193,11 @@ phrase\"."
;; Expires = HTTP-date ;; Expires = HTTP-date
;; ;;
(declare-date-header expires (declare-date-header! "Expires")
"Expires")
;; Last-Modified = HTTP-date ;; Last-Modified = HTTP-date
;; ;;
(declare-date-header last-modified (declare-date-header! "Last-Modified")
"Last-Modified")
@ -1286,8 +1212,7 @@ phrase\"."
;; accept-params = ";" "q" "=" qvalue *( accept-extension ) ;; accept-params = ";" "q" "=" qvalue *( accept-extension )
;; accept-extension = ";" token [ "=" ( token | quoted-string ) ] ;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
;; ;;
(declare-param-list-header accept (declare-param-list-header! "Accept"
"Accept"
;; -> ("type/subtype" (str-prop . str-val) ...) ...) ;; -> ("type/subtype" (str-prop . str-val) ...) ...)
;; ;;
;; with the exception of prop = "q", in which case the prop will be ;; with the exception of prop = "q", in which case the prop will be
@ -1309,28 +1234,24 @@ phrase\"."
;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] ) ;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] )
;; ;;
(declare-quality-list-header accept-charset (declare-quality-list-header! "Accept-Charset")
"Accept-Charset")
;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] ) ;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] )
;; codings = ( content-coding | "*" ) ;; codings = ( content-coding | "*" )
;; ;;
(declare-quality-list-header accept-encoding (declare-quality-list-header! "Accept-Encoding")
"Accept-Encoding")
;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] ) ;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] )
;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" ) ;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )
;; ;;
(declare-quality-list-header accept-language (declare-quality-list-header! "Accept-Language")
"Accept-Language")
;; Authorization = credentials ;; Authorization = credentials
;; ;;
;; Authorization is basically opaque to this HTTP stack, we just pass ;; Authorization is basically opaque to this HTTP stack, we just pass
;; the string value through. ;; the string value through.
;; ;;
(declare-opaque-header authorization (declare-opaque-header! "Authorization")
"Authorization")
;; Expect = 1#expectation ;; Expect = 1#expectation
;; expectation = "100-continue" | expectation-extension ;; expectation = "100-continue" | expectation-extension
@ -1338,8 +1259,7 @@ phrase\"."
;; *expect-params ] ;; *expect-params ]
;; expect-params = ";" token [ "=" ( token | quoted-string ) ] ;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
;; ;;
(declare-param-list-header expect (declare-param-list-header! "Expect"
"Expect"
(lambda (k) (lambda (k)
(if (equal? k "100-continue") (if (equal? k "100-continue")
'100-continue '100-continue
@ -1349,13 +1269,11 @@ phrase\"."
;; ;;
;; Should be an email address; we just pass on the string as-is. ;; Should be an email address; we just pass on the string as-is.
;; ;;
(declare-opaque-header from (declare-opaque-header! "From")
"From")
;; Host = host [ ":" port ] ;; Host = host [ ":" port ]
;; ;;
(declare-header host (declare-header! "Host"
"Host"
(lambda (str) (lambda (str)
(let ((colon (string-index str #\:))) (let ((colon (string-index str #\:)))
(if colon (if colon
@ -1376,23 +1294,19 @@ phrase\"."
;; If-Match = ( "*" | 1#entity-tag ) ;; If-Match = ( "*" | 1#entity-tag )
;; ;;
(declare-entity-tag-list-header if-match (declare-entity-tag-list-header! "If-Match")
"If-Match")
;; If-Modified-Since = HTTP-date ;; If-Modified-Since = HTTP-date
;; ;;
(declare-date-header if-modified-since (declare-date-header! "If-Modified-Since")
"If-Modified-Since")
;; If-None-Match = ( "*" | 1#entity-tag ) ;; If-None-Match = ( "*" | 1#entity-tag )
;; ;;
(declare-entity-tag-list-header if-none-match (declare-entity-tag-list-header! "If-None-Match")
"If-None-Match")
;; If-Range = ( entity-tag | HTTP-date ) ;; If-Range = ( entity-tag | HTTP-date )
;; ;;
(declare-header if-range (declare-header! "If-Range"
"If-Range"
(lambda (str) (lambda (str)
(if (or (string-prefix? "\"" str) (if (or (string-prefix? "\"" str)
(string-prefix? "W/" str)) (string-prefix? "W/" str))
@ -1407,18 +1321,15 @@ phrase\"."
;; If-Unmodified-Since = HTTP-date ;; If-Unmodified-Since = HTTP-date
;; ;;
(declare-date-header if-unmodified-since (declare-date-header! "If-Unmodified-Since")
"If-Unmodified-Since")
;; Max-Forwards = 1*DIGIT ;; Max-Forwards = 1*DIGIT
;; ;;
(declare-integer-header max-forwards (declare-integer-header! "Max-Forwards")
"Max-Forwards")
;; Proxy-Authorization = credentials ;; Proxy-Authorization = credentials
;; ;;
(declare-opaque-header proxy-authorization (declare-opaque-header! "Proxy-Authorization")
"Proxy-Authorization")
;; Range = "Range" ":" ranges-specifier ;; Range = "Range" ":" ranges-specifier
;; ranges-specifier = byte-ranges-specifier ;; ranges-specifier = byte-ranges-specifier
@ -1430,8 +1341,7 @@ phrase\"."
;; suffix-byte-range-spec = "-" suffix-length ;; suffix-byte-range-spec = "-" suffix-length
;; suffix-length = 1*DIGIT ;; suffix-length = 1*DIGIT
;; ;;
(declare-header range (declare-header! "Range"
"Range"
(lambda (str) (lambda (str)
(if (string-prefix? "bytes=" str) (if (string-prefix? "bytes=" str)
(cons (cons
@ -1475,20 +1385,17 @@ phrase\"."
;; Referer = ( absoluteURI | relativeURI ) ;; Referer = ( absoluteURI | relativeURI )
;; ;;
(declare-uri-header referer (declare-uri-header! "Referer")
"Referer")
;; TE = #( t-codings ) ;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
;; ;;
(declare-param-list-header te (declare-param-list-header! "TE"
"TE"
(lambda (k) (if (equal? k "trailers") 'trailers k))) (lambda (k) (if (equal? k "trailers") 'trailers k)))
;; User-Agent = 1*( product | comment ) ;; User-Agent = 1*( product | comment )
;; ;;
(declare-opaque-header user-agent (declare-opaque-header! "User-Agent")
"User-Agent")
@ -1500,38 +1407,32 @@ phrase\"."
;; Accept-Ranges = acceptable-ranges ;; Accept-Ranges = acceptable-ranges
;; acceptable-ranges = 1#range-unit | "none" ;; acceptable-ranges = 1#range-unit | "none"
;; ;;
(declare-string-list-header accept-ranges (declare-string-list-header! "Accept-Ranges")
"Accept-Ranges")
;; Age = age-value ;; Age = age-value
;; age-value = delta-seconds ;; age-value = delta-seconds
;; ;;
(declare-integer-header age (declare-integer-header! "Age")
"Age")
;; ETag = entity-tag ;; ETag = entity-tag
;; ;;
(declare-header etag (declare-header! "ETag"
"ETag"
parse-entity-tag parse-entity-tag
entity-tag? entity-tag?
write-entity-tag) write-entity-tag)
;; Location = absoluteURI ;; Location = absoluteURI
;; ;;
(declare-uri-header location (declare-uri-header! "Location")
"Location")
;; Proxy-Authenticate = 1#challenge ;; Proxy-Authenticate = 1#challenge
;; ;;
;; FIXME: split challenges ? ;; FIXME: split challenges ?
(declare-opaque-header proxy-authenticate (declare-opaque-header! "Proxy-Authenticate")
"Proxy-Authenticate")
;; Retry-After = ( HTTP-date | delta-seconds ) ;; Retry-After = ( HTTP-date | delta-seconds )
;; ;;
(declare-header retry-after (declare-header! "Retry-After"
"Retry-After"
(lambda (str) (lambda (str)
(if (and (not (string-null? str)) (if (and (not (string-null? str))
(char-numeric? (string-ref str 0))) (char-numeric? (string-ref str 0)))
@ -1546,13 +1447,11 @@ phrase\"."
;; Server = 1*( product | comment ) ;; Server = 1*( product | comment )
;; ;;
(declare-opaque-header server (declare-opaque-header! "Server")
"Server")
;; Vary = ( "*" | 1#field-name ) ;; Vary = ( "*" | 1#field-name )
;; ;;
(declare-header vary (declare-header! "Vary"
"Vary"
(lambda (str) (lambda (str)
(if (equal? str "*") (if (equal? str "*")
'* '*
@ -1567,5 +1466,4 @@ phrase\"."
;; WWW-Authenticate = 1#challenge ;; WWW-Authenticate = 1#challenge
;; ;;
;; Hum. ;; Hum.
(declare-opaque-header www-authenticate (declare-opaque-header! "WWW-Authenticate")
"WWW-Authenticate")

12
module/web/request.scm
View file

@ -1,6 +1,6 @@
;;; HTTP request objects ;;; HTTP request objects
;; Copyright (C) 2010 Free Software Foundation, Inc. ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -142,13 +142,9 @@
(let ((h (car headers))) (let ((h (car headers)))
(if (pair? h) (if (pair? h)
(let ((k (car h)) (v (cdr h))) (let ((k (car h)) (v (cdr h)))
(if (symbol? k) (if (valid-header? k v)
(if (not (valid-header? k v)) (validate-headers (cdr headers))
(bad-request "Bad value for header ~a: ~s" k v)) (bad-request "Bad value for header ~a: ~s" k v)))
(if (not (and (string? k) (string? v)))
(bad-request "Unknown header not a pair of strings: ~s"
h)))
(validate-headers (cdr headers)))
(bad-request "Header not a pair: ~a" h))) (bad-request "Header not a pair: ~a" h)))
(if (not (null? headers)) (if (not (null? headers))
(bad-request "Headers not a list: ~a" headers)))) (bad-request "Headers not a list: ~a" headers))))

12
module/web/response.scm
View file

@ -1,6 +1,6 @@
;;; HTTP response objects ;;; HTTP response objects
;; Copyright (C) 2010 Free Software Foundation, Inc. ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -101,13 +101,9 @@
(let ((h (car headers))) (let ((h (car headers)))
(if (pair? h) (if (pair? h)
(let ((k (car h)) (v (cdr h))) (let ((k (car h)) (v (cdr h)))
(if (symbol? k) (if (valid-header? k v)
(if (not (valid-header? k v)) (validate-headers (cdr headers))
(bad-response "Bad value for header ~a: ~s" k v)) (bad-response "Bad value for header ~a: ~s" k v)))
(if (not (and (string? k) (string? v)))
(bad-response "Unknown header not a pair of strings: ~s"
h)))
(validate-headers (cdr headers)))
(bad-response "Header not a pair: ~a" h))) (bad-response "Header not a pair: ~a" h)))
(if (not (null? headers)) (if (not (null? headers))
(bad-response "Headers not a list: ~a" headers)))) (bad-response "Headers not a list: ~a" headers))))

19
test-suite/tests/web-http.test
View file

@ -1,6 +1,6 @@
;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
;;;; ;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -41,9 +41,8 @@
(syntax-rules () (syntax-rules ()
((_ sym str val) ((_ sym str val)
(pass-if (format #f "~a: ~s -> ~s" 'sym str val) (pass-if (format #f "~a: ~s -> ~s" 'sym str val)
(call-with-values (lambda () (parse-header (symbol->string 'sym) str)) (equal? (parse-header 'sym str)
(lambda (k v) val)))))
(equal? v val)))))))
(define-syntax pass-if-any-error (define-syntax pass-if-any-error
(syntax-rules () (syntax-rules ()
@ -51,7 +50,7 @@
(pass-if (format #f "~a: ~s -> any error" 'sym str) (pass-if (format #f "~a: ~s -> any error" 'sym str)
(% (catch #t (% (catch #t
(lambda () (lambda ()
(parse-header (symbol->string 'sym) str) (parse-header 'sym str)
(abort (lambda () (error "expected exception")))) (abort (lambda () (error "expected exception"))))
(lambda (k . args) (lambda (k . args)
#t)) #t))
@ -64,7 +63,7 @@
(pass-if (format #f "~a: ~s -> ~a error" 'sym str 'expected-component) (pass-if (format #f "~a: ~s -> ~a error" 'sym str 'expected-component)
(catch 'bad-header (catch 'bad-header
(lambda () (lambda ()
(parse-header (symbol->string 'sym) str) (parse-header 'sym str)
(error "expected exception" 'expected-component)) (error "expected exception" 'expected-component))
(lambda (k component arg) (lambda (k component arg)
(if (or (not 'expected-component) (if (or (not 'expected-component)
@ -80,7 +79,7 @@
(pass-if-parse cache-control "no-cache=\"Authorization, Date\"" (pass-if-parse cache-control "no-cache=\"Authorization, Date\""
'((no-cache . (authorization date)))) '((no-cache . (authorization date))))
(pass-if-parse cache-control "private=\"Foo\"" (pass-if-parse cache-control "private=\"Foo\""
'((private . ("Foo")))) '((private . (foo))))
(pass-if-parse cache-control "no-cache,max-age=10" (pass-if-parse cache-control "no-cache,max-age=10"
'(no-cache (max-age . 10))) '(no-cache (max-age . 10)))
@ -96,8 +95,8 @@
(pass-if-parse pragma "no-cache" '(no-cache)) (pass-if-parse pragma "no-cache" '(no-cache))
(pass-if-parse pragma "no-cache, foo" '(no-cache "foo")) (pass-if-parse pragma "no-cache, foo" '(no-cache "foo"))
(pass-if-parse trailer "foo, bar" '("foo" "bar")) (pass-if-parse trailer "foo, bar" '(foo bar))
(pass-if-parse trailer "connection, bar" '(connection "bar")) (pass-if-parse trailer "connection, bar" '(connection bar))
(pass-if-parse transfer-encoding "foo, chunked" '(("foo") (chunked))) (pass-if-parse transfer-encoding "foo, chunked" '(("foo") (chunked)))
@ -201,5 +200,5 @@
(pass-if-parse retry-after "20" 20) (pass-if-parse retry-after "20" 20)
(pass-if-parse server "guile!" "guile!") (pass-if-parse server "guile!" "guile!")
(pass-if-parse vary "*" '*) (pass-if-parse vary "*" '*)
(pass-if-parse vary "foo, bar" '("foo" "bar")) (pass-if-parse vary "foo, bar" '(foo bar))
(pass-if-parse www-authenticate "secret" "secret")) (pass-if-parse www-authenticate "secret" "secret"))