guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. release_1-9-14-50-gff


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-14-50-gff8339d
Date: Mon, 10 Jan 2011 17:30:40 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ff8339db69811ef9c736379b9127e60a3ff74b05

The branch, master has been updated
       via  ff8339db69811ef9c736379b9127e60a3ff74b05 (commit)
       via  ecfb7167cbc239a4b4f11cb8287e8116c2760cff (commit)
       via  94f16a5b8f51af91e273f9886e8ffa54eb3bd9c0 (commit)
       via  0acc595b943dedf6bf429e21e7b69aa2fcec767a (commit)
       via  32de1aa783c65a7c489c924b3fa41ee08187c15b (commit)
       via  7118eccd72a47fcce3528947f655c71d4996d2e8 (commit)
       via  be1be3e597947038a497610eac3053508bf0d7f2 (commit)
      from  a574564c24f5d08790f5a429c0f285938363a3f0 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit ff8339db69811ef9c736379b9127e60a3ff74b05
Author: Andy Wingo <address@hidden>
Date:   Mon Jan 10 09:32:26 2011 -0800

    update web.texi for (web http) changes
    
    * doc/ref/web.texi (HTTP Headers): Update to reflect current code, and
      to reformat. Not sure if it's an improvement...

commit ecfb7167cbc239a4b4f11cb8287e8116c2760cff
Author: Andy Wingo <address@hidden>
Date:   Mon Jan 10 08:20:29 2011 -0800

    parse credentials and challenges
    
    * module/web/http.scm (parse-credentials, validate-credentials)
      (write-credentials, parse-challenge, parse-challenges)
      (validate-challenges, write-challenge, write-challenges)
      (declare-credentials-header!, declare-challenge-list-header!): New
      helpers.
      ("Authorization", "Proxy-Authorization"): Parse out credentials.
      ("Proxy-Authenticate", "WWW-Authenticate"): Parse out challenges.

commit 94f16a5b8f51af91e273f9886e8ffa54eb3bd9c0
Author: Andy Wingo <address@hidden>
Date:   Sat Jan 8 21:32:14 2011 -0800

    more symbols in (web http)
    
    * module/web/http.scm (declare-symbol-list-header!): New helper.
      ("Connection"): Redefine as a header list.
      ("Allow", "Content-Encoding", "Accept-Ranges"): Redefine as symbol
      lists.
    
    * test-suite/tests/web-http.test:
    * test-suite/tests/web-response.test: Adapt tests.

commit 0acc595b943dedf6bf429e21e7b69aa2fcec767a
Author: Andy Wingo <address@hidden>
Date:   Sat Jan 8 20:50:46 2011 -0800

    (web http): keys are always symbols
    
    * module/web/http.scm (parse-media-type): Parse media types as symbols.
      (parse-key-value-list, parse-param-component, parse-param-list):
      Change kons to val-parser. Always parse keys as symbols, and always
      either cons, if there is a val, or just have the key, if there is no
      val.  Easier to explain and just as correct.
      (declare-param-list-header!, declare-key-value-list-header!): Adapt to
      key-list and param-list kons change.
      ("Cache-Control", "Pragma", "Transfer-Encoding", "Accept", "Expect")
      ("TE"): Likewise, adapt.
      ("Content-Type"): Param keys are symbols.

commit 32de1aa783c65a7c489c924b3fa41ee08187c15b
Author: Andy Wingo <address@hidden>
Date:   Sat Jan 8 12:21:38 2011 -0800

    update (web http) docs
    
    * doc/ref/web.texi (HTTP): Update docs to correspond with current code.

commit 7118eccd72a47fcce3528947f655c71d4996d2e8
Author: Andy Wingo <address@hidden>
Date:   Sat Jan 8 11:40:20 2011 -0800

    (web http): don't expose header-decl objects
    
    * module/web/http.scm: Change to not expose the header-decl objects,
      instead exposing header-parse, header-validator, header-writer et al.
      Explaining header decls in the manual was too complicated.
      (string->header, header->string): New helpers.
      (<header-decl>): Remove the `sym' field.
      (declare-header!): Adapt to header-decl change, and use
      string->header.
      (known-header?, header-parser, header-validator, header-writer): New
      procedures.
    
      Adapt to use the new procedures internally.

commit be1be3e597947038a497610eac3053508bf0d7f2
Author: Andy Wingo <address@hidden>
Date:   Sat Jan 8 10:54:07 2011 -0800

    (web http): header names always represented as symbols
    
    * 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.

-----------------------------------------------------------------------

Summary of changes:
 doc/ref/web.texi                   |  765 +++++++++++++++++++++++++-----------
 examples/web/debug-sxml.scm        |    4 +-
 examples/web/hello.scm             |    2 +-
 module/web/http.scm                |  732 ++++++++++++++++++-----------------
 module/web/request.scm             |   12 +-
 module/web/response.scm            |   12 +-
 module/web/server.scm              |   16 +-
 test-suite/tests/web-http.test     |   65 ++--
 test-suite/tests/web-request.test  |   14 +-
 test-suite/tests/web-response.test |   10 +-
 10 files changed, 982 insertions(+), 650 deletions(-)

diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index ca5b122..56b9720 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010 Free Software Foundation, Inc.
address@hidden Copyright (C) 2010, 2011 Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node Web
@@ -319,43 +319,64 @@ Guile 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.
 
-The first bit is to define a registry of parsers, validators, and
-unparsers, keyed by header name.  That is the function of the
address@hidden<header-decl>} object.
-
address@hidden make-header-decl sym name multiple? parser validator writer
address@hidden header-decl? x
address@hidden header-decl-sym decl
address@hidden header-decl-name decl
address@hidden header-decl-multiple? decl
address@hidden header-decl-parser decl
address@hidden header-decl-validator decl
address@hidden header-decl-writer decl.
-A constructor, predicate, and field accessors for the
address@hidden<header-decl>} type. The fields are as follows:
+Header names are represented as lower-case symbols.
 
address@hidden @code
address@hidden sym
-The symbol name for this header field, always in lower-case.  For
-example, @code{"Content-Length"} has a symbolic name of
address@hidden
address@hidden name
-The string name of the header, in its preferred capitalization.
address@hidden multiple?
address@hidden iff this header may appear multiple times in a message.
address@hidden parser
-A procedure which takes a string and returns a parsed value.
address@hidden validator
-A predicate, returning @code{#t} iff the value is valid for this header.
address@hidden writer
-A writer, which writes a value to the port given in the second argument.
address@hidden table
address@hidden string->header name
+Parse @var{name} to a symbolic header name.
 @end defun
 
address@hidden declare-header! sym name [#:address@hidden [#:parser] 
[#:validator] [#:writer]
-Make a header declaration, as above, and register it by symbol and by
-name. The @var{parser}, @var{validator}, and @var{writer} arguments are
-all mandatory.
address@hidden header->string sym
+Return the string form for the header named @var{sym}.
address@hidden defun
+
+For example:
+
address@hidden
+(string->header "Content-Length")
address@hidden content-length
+(header->string 'content-length)
address@hidden "Content-Length"
+
+(string->header "FOO")
address@hidden foo
+(header->string 'foo
address@hidden "Foo"
address@hidden example
+
+Guile keeps a registry of known headers, their string names, and some
+parsing and serialization procedures.  If a header is unknown, its
+string name is simply its symbol name in title-case.
+
address@hidden known-header? sym
+Return @code{#t} iff @var{sym} is a known header, with associated
+parsers and serialization procedures.
address@hidden defun
+
address@hidden header-parser sym
+Return the value parser for headers named @var{sym}.  The result is a
+procedure that takes one argument, a string, and returns the parsed
+value.  If the header isn't known to Guile, a default parser is returned
+that passes through the string unchanged.
address@hidden defun
+
address@hidden header-validator sym
+Return a predicate which returns @code{#t} if the given value is valid
+for headers named @var{sym}.  The default validator for unknown headers
+is @code{string?}.
address@hidden defun
+
address@hidden header-writer sym
+Return a procedure that writes values for headers named @var{sym} to a
+port.  The resulting procedure takes two arguments: a value and a port.
+The default writer is @code{display}.
address@hidden defun
+
+For more on the set of headers that Guile knows about out of the box,
address@hidden Headers}.  To add your own, use the @code{declare-header!}
+procedure:
+
address@hidden declare-header! name parser validator writer [#:address@hidden
+Declare a parser, validator, and writer for a given header.
 @end defun
 
 For example, let's say you are running a web server behind some sort of
@@ -372,23 +393,15 @@ HTTP stack like this:
 (define (write-ip ip port)
   (display (inet-ntoa ip) port))
 
-(declare-header! 'x-client-address
-  "X-Client-Address"
-  #:parser    (lambda (str)
-                (inet-aton str))
-  #:validator (lambda (ip)
-                (and (integer? ip) (exact? ip) (<= 0 ip 4294967295)))
-  #:writer    (lambda (ip port)
-                (display (inet-ntoa ip) port)))
+(declare-header! "X-Client-Address"
+  (lambda (str)
+    (inet-aton str))
+  (lambda (ip)
+    (and (integer? ip) (exact? ip) (<= 0 ip #xffffffff)))
+  (lambda (ip port)
+    (display (inet-ntoa ip) port)))
 @end example
 
address@hidden lookup-header-decl name
-Return the @var{header-decl} object registered for the given @var{name}.
-
address@hidden may be a symbol or a string. Strings are mapped to headers in
-a case-insensitive fashion.
address@hidden defun
-
 @defun valid-header? sym val
 Return a true value iff @var{val} is a valid Scheme value for the header
 with name @var{sym}.
@@ -408,17 +421,12 @@ body was reached (i.e., a blank line).
 
 @defun parse-header name val
 Parse @var{val}, a string, with the parser for the header named
address@hidden
-
-Return 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.
address@hidden  Returns the parsed value.
 @end defun
 
 @defun write-header name val port
-Writes the given header name and value to @var{port}. If @var{name} is a
-symbol, looks up a declared header and uses that writer. Otherwise the
-value is written using @var{display}.
+Write the given header name and value to @var{port}, using the writer
+from @code{header-writer}.
 @end defun
 
 @defun read-headers port
@@ -428,7 +436,7 @@ headers as an ordered alist.
 
 @defun 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.
address@hidden, as the user might want to add another header.
 @end defun
 
 The @code{(web http)} module also has some utility procedures to read
@@ -472,243 +480,550 @@ Write the first line of an HTTP response to @var{port}.
 @node HTTP Headers
 @subsection HTTP Headers
 
-The @code{(web http)} module defines parsers and unparsers for all
-headers defined in the HTTP/1.1 standard.  This section describes the
-parsed format of the various headers.
-
-We cannot describe the function of all of these headers, however, in
-sufficient detail.  The interested reader would do well to download a
-copy of RFC 2616 and have it on hand.
-
-To begin with, we should make a few definitions:
-
address@hidden @dfn
address@hidden key-value list
-A key-value list is a list of values.  Each value may be a string,
-a symbol, or a pair.  Known keys are parsed to symbols; otherwise keys
-are left as strings.  Keys with values are parsed to pairs, the car of
-which is the symbol or string key, and the cdr is the parsed value.
-Parsed values for known keys have key-dependent formats.  Parsed values
-for unknown keys are strings.
-
address@hidden param list
-A param list is a list of key-value lists.  When serialized to a string,
-items in the inner lists are separated by semicolons.  Again, known keys
-are parsed to symbols.
-
address@hidden quality
-A number of headers have quality values in them, which are decimal
-fractions between zero and one indicating a preference for various kinds
-of responses, which the server may choose to heed.  Given that only
-three digits are allowed in the fractional part, Guile parses quality
-values to integers between 0 and 1000 instead of inexact numbers between
-0.0 and 1.0.
-
address@hidden quality list
-A list of pairs, the car of which is a quality value.
-
address@hidden entity tag
-A pair, the car of which is an opaque string, and the cdr of which is
-true iff the entity tag is a ``strong'' entity tag.
address@hidden table
+In addition to defining the infrastructure to parse headers, the
address@hidden(web http)} module defines specific parsers and unparsers for all
+headers defined in the HTTP/1.1 standard.
+
+For example, if you receive a header named @samp{Accept-Language} with a
+value @samp{en, es;q=0.8}, Guile parses it as a quality list (defined
+below):
+
address@hidden
+(parse-header 'accept-language "en, es;q=0.8")
address@hidden ((1000 . "en") (800 . "es"))
address@hidden example
+
+The format of the value for @samp{Accept-Language} headers is defined
+below, along with all other headers defined in the HTTP standard.  (If
+the header were unknown, the value would have been returned as a
+string.)
+
+For brevity, the header definitions below are given in the form,
address@hidden @address@hidden, indicating that values for the header
address@hidden@var{name}} will be of the given @var{Type}.  Since Guile
+internally treats header names in lower case, in this document we give
+types title-cased names.  A short description of the each header's
+purpose and an example follow.
 
+For full details on the meanings of all of these headers, see the HTTP
+1.1 standard, RFC 2616.
+
address@hidden HTTP Header Types
+
+Here we define the types that are used below, when defining headers.
+
address@hidden {HTTP Header Type} Date
+A SRFI-19 date.
address@hidden deftp
+
address@hidden {HTTP Header Type} KVList
+A list whose elements are keys or key-value pairs.  Keys are parsed to
+symbols.  Values are strings by default.  Non-string values are the
+exception, and are mentioned explicitly below, as appropriate.
address@hidden deftp
+
address@hidden {HTTP Header Type} SList
+A list of strings.
address@hidden deftp
+
address@hidden {HTTP Header Type} Quality
+An exact integer between 0 and 1000.  Qualities are used to express
+preference, given multiple options.  An option with a quality of 870,
+for example, is preferred over an option with quality 500.
+
+(Qualities are written out over the wire as numbers between 0.0 and
+1.0, but since the standard only allows three digits after the decimal,
+it's equivalent to integers between 0 and 1000, so that's what Guile
+uses.)
address@hidden deftp
+
address@hidden {HTTP Header Type} QList
+A quality list: a list of pairs, the car of which is a quality, and the
+cdr a string.  Used to express a list of options, along with their
+qualities.
address@hidden deftp
+
address@hidden {HTTP Header Type} ETag
+An entity tag, represented as a pair.  The car of the pair is an opaque
+string, and the cdr is @code{#t} if the entity tag is a ``strong'' entity
+tag, and @code{#f} otherwise.
address@hidden deftp
 
 @subsubsection General Headers
 
address@hidden @code
address@hidden cache-control
-A key-value list of cache-control directives. Known keys are
address@hidden, @code{max-stale}, @code{min-fresh},
address@hidden, @code{no-cache}, @code{no-store},
address@hidden, @code{only-if-cached}, @code{private},
address@hidden, @code{public}, and @code{s-maxage}.
+General HTTP headers may be present in any HTTP message.
+
address@hidden {HTTP Header} KVList cache-control
+A key-value list of cache-control directives.  See RFC 2616, for more
+details.
 
 If present, parameters to @code{max-age}, @code{max-stale},
 @code{min-fresh}, and @code{s-maxage} are all parsed as non-negative
 integers.
 
 If present, parameters to @code{private} and @code{no-cache} are parsed
-as lists of header names, represented as symbols if they are known
-headers or strings otherwise.
+as lists of header names, as symbols.
 
address@hidden connection
-A list of connection tokens.  A connection token is a string.
address@hidden
+(parse-header 'cache-control "no-cache,no-store"
address@hidden (no-cache no-store)
+(parse-header 'cache-control "no-cache=\"Authorization,Date\",no-store"
address@hidden ((no-cache . (authorization date)) no-store)
+(parse-header 'cache-control "no-cache=\"Authorization,Date\",max-age=10"
address@hidden ((no-cache . (authorization date)) (max-age . 10))
address@hidden example
address@hidden deftypevr
 
address@hidden date
-A SRFI-19 date record.
address@hidden {HTTP Header} List connection
+A list of header names that apply only to this HTTP connection, as
+symbols.  Additionally, the symbol @samp{close} may be present, to
+indicate that the server should close the connection after responding to
+the request.
address@hidden
+(parse-header 'connection "close")
address@hidden (close)
address@hidden example
address@hidden deftypevr
 
address@hidden pragma
-A key-value list of pragma directives.  @code{no-cache} is the only
-known key.
address@hidden {HTTP Header} Date date
+The date that a given HTTP message was originated.
address@hidden
+(parse-header 'date "Tue, 15 Nov 1994 08:12:31 GMT")
address@hidden #<date ...>
address@hidden example
address@hidden deftypevr
 
address@hidden trailer
-A list of header names.  Known header names are parsed to symbols,
-otherwise they are left as strings.
address@hidden {HTTP Header} KVList pragma
+A key-value list of implementation-specific directives.
address@hidden
+(parse-header 'pragma "no-cache, broccoli=tasty")
address@hidden (no-cache (broccoli . "tasty"))
address@hidden example
address@hidden deftypevr
 
address@hidden transfer-encoding
-A param list of transfer codings.  @code{chunked} is the only known key.
address@hidden {HTTP Header} List trailer
+A list of header names which will appear after the message body, instead
+of with the message headers.
address@hidden
+(parse-header 'trailer "ETag")
address@hidden (etag)
address@hidden example
address@hidden deftypevr
 
address@hidden upgrade
-A list of strings.
address@hidden {HTTP Header} List transfer-encoding
+A list of transfer codings, expressed as key-value lists.  The only
+transfer coding defined by the specification is @code{chunked}.
address@hidden
+(parse-header 'transfer-encoding "chunked")
address@hidden (chunked)
address@hidden example
address@hidden deftypevr
 
address@hidden via
-A list of strings.  There may be multiple @code{via} headers in ne
-message.
address@hidden {HTTP Header} List upgrade
+A list of strings, indicating additional protocols that a server could use
+in response to a request.
address@hidden
+(parse-header 'upgrade "WebSocket")
address@hidden ("WebSocket")
address@hidden example
address@hidden deftypevr
 
address@hidden warning
-A list of warnings.  Each warning is a itself a list of four elements: a
-code, as an exact integer between 0 and 1000, a host as a string, the
-warning text as a string, and either @code{#f} or a SRFI-19 date.
+FIXME: parse out more fully?
address@hidden {HTTP Header} List via
+A list of strings, indicating the protocol versions and hosts of
+intermediate servers and proxies.  There may be multiple @code{via}
+headers in one message.
address@hidden
+(parse-header 'via "1.0 venus, 1.1 mars")
address@hidden ("1.0 venus" "1.1 mars")
address@hidden example
address@hidden deftypevr
+
address@hidden {HTTP Header} List warning
+A list of warnings given by a server or intermediate proxy.  Each
+warning is a itself a list of four elements: a code, as an exact integer
+between 0 and 1000, a host as a string, the warning text as a string,
+and either @code{#f} or a SRFI-19 date.
 
 There may be multiple @code{warning} headers in one message.
address@hidden table
address@hidden
+(parse-header 'warning "123 foo \"core breach imminent\"")
address@hidden ((123 "foo" "core-breach imminent" #f))
address@hidden example
address@hidden deftypevr
 
 
 @subsubsection Entity Headers
 
address@hidden @code
address@hidden allow
-A list of methods, as strings.  Methods are parsed as strings instead of
address@hidden so as to allow for new methods.
-
address@hidden content-encoding
-A list of content codings, as strings.
-
address@hidden content-language
-A list of language tags, as strings.
+Entity headers may be present in any HTTP message, and refer to the
+resource referenced in the HTTP request or response.
 
address@hidden content-length
-An exact, non-negative integer.
-
address@hidden content-location
-A URI record.
address@hidden {HTTP Header} List allow
+A list of allowed methods on a given resource, as symbols.
address@hidden
+(parse-header 'allow "GET, HEAD")
address@hidden (GET HEAD)
address@hidden example
address@hidden deftypevr
 
address@hidden content-md5
-A string.
address@hidden {HTTP Header} List content-encoding
+A list of content codings, as symbols.
address@hidden
+(parse-header 'content-encoding "gzip")
address@hidden (GET HEAD)
address@hidden example
address@hidden deftypevr
 
address@hidden content-range
-A list of three elements: the symbol @code{bytes}, either the symbol
address@hidden or a pair of integers, indicating the byte rage, and either
address@hidden or an integer, for the instance length.
address@hidden {HTTP Header} List content-language
+The languages that a resource is in, as strings.
address@hidden
+(parse-header 'content-language "en")
address@hidden ("en")
address@hidden example
address@hidden deftypevr
 
address@hidden content-type
-A pair, the car of which is the media type as a string, and the cdr is
-an alist of parameters, with strings as keys and values.
address@hidden {HTTP Header} UInt content-length
+The number of bytes in a resource, as an exact, non-negative integer.
address@hidden
+(parse-header 'content-length "300")
address@hidden 300
address@hidden example
address@hidden deftypevr
 
-For example, @code{"text/plain"} parses as @code{("text/plain")}, and
address@hidden"text/plain;charset=utf-8"} parses as @code{("text/plain"
-("charset" . "utf-8"))}.
address@hidden {HTTP Header} URI content-location
+The canonical URI for a resource, in the case that it is also accessible
+from a different URI.
address@hidden
+(parse-header 'content-location "http://example.com/foo";)
address@hidden #<<uri> ...>
address@hidden example
address@hidden deftypevr
 
address@hidden expires
-A SRFI-19 date.
address@hidden {HTTP Header} String content-md5
+The MD5 digest of a resource.
address@hidden
+(parse-header 'content-md5 "ffaea1a79810785575e29e2bd45e2fa5")
address@hidden "ffaea1a79810785575e29e2bd45e2fa5"
address@hidden example
address@hidden deftypevr
+
address@hidden {HTTP Header} List content-range
+A range specification, as a list of three elements: the symbol
address@hidden, either the symbol @code{*} or a pair of integers,
+indicating the byte rage, and either @code{*} or an integer, for the
+instance length.  Used to indicate that a response only includes part of
+a resource.
address@hidden
+(parse-header 'content-range "bytes 10-20/*")
address@hidden (bytes (10 . 20) *)
address@hidden example
address@hidden deftypevr
 
address@hidden last-modified
-A SRFI-19 date.
address@hidden {HTTP Header} List content-type
+The MIME type of a resource, as a symbol, along with any parameters.
address@hidden
+(parse-header 'content-length "text/plain")
address@hidden (text/plain)
+(parse-header 'content-length "text/plain;charset=utf-8")
address@hidden (text/plain (charset . "utf-8"))
address@hidden example
+Note that the @code{charset} parameter is something is a misnomer, and
+the HTTP specification admits this.  It specifies the @emph{encoding} of
+the characters, not the character set.
address@hidden deftypevr
+
address@hidden {HTTP Header} Date expires
+The date/time after which the resource given in a response is considered
+stale.
address@hidden
+(parse-header 'expires "Tue, 15 Nov 1994 08:12:31 GMT")
address@hidden #<date ...>
address@hidden example
address@hidden deftypevr
 
address@hidden table
address@hidden {HTTP Header} Date last-modified
+The date/time on which the resource given in a response was last
+modified.
address@hidden
+(parse-header 'expires "Tue, 15 Nov 1994 08:12:31 GMT")
address@hidden #<date ...>
address@hidden example
address@hidden deftypevr
 
 
 @subsubsection Request Headers
 
address@hidden @code
address@hidden accept
-A param list.  Each element in the list indicates one media-range
-with accept-params.  They only known key is @code{q}, whose value is
-parsed as a quality value.
-
address@hidden accept-charset
-A quality-list of charsets, as strings.
+Request headers may only appear in an HTTP request, not in a response.
 
address@hidden accept-encoding
-A quality-list of content codings, as strings.
address@hidden {HTTP Header} List accept
+A list of preferred media types for a response.  Each element of the
+list is itself a list, in the same format as @code{content-type}.  
address@hidden
+(parse-header 'accept "text/html,text/plain;charset=utf-8")
address@hidden ((text/html) (text/plain (charset . "utf-8")))
address@hidden example
+Preference is expressed with qualitiy values:
address@hidden
+(parse-header 'accept "text/html;q=0.8,text/plain;q=0.6")
address@hidden ((text/html (q . 800)) (text/plain (q . 600)))
address@hidden example
address@hidden deftypevr
 
address@hidden accept-language
-A quality-list of languages, as strings.
address@hidden {HTTP Header} QList accept-charset
+A quality list of acceptable charsets.  Note again that what HTTP calls
+a ``charset'' is what Guile calls a ``character encoding''.
address@hidden
+(parse-header 'accept-charset "iso-8859-5, unicode-1-1;q=0.8")
address@hidden ((1000 . "iso-8859-5") (800 . "unicode-1-1"))
address@hidden example
address@hidden deftypevr
 
address@hidden authorization
-A string.
address@hidden {HTTP Header} QList accept-encoding
+A quality list of acceptable content codings.
address@hidden
+(parse-header 'accept-encoding "gzip,identity=0.8")
address@hidden ((1000 . "gzip") (800 . "identity"))
address@hidden example
address@hidden deftypevr
 
address@hidden expect
-A param list of expectations.  The only known key is
address@hidden
address@hidden {HTTP Header} QList accept-language
+A quality list of acceptable languages.
address@hidden
+(parse-header 'accept-language "cn,en=0.75")
address@hidden ((1000 . "cn") (750 . "en"))
address@hidden example
address@hidden deftypevr
+
address@hidden {HTTP Header} Pair authorization
+Authorization credentials.  The car of the pair indicates the
+authentication scheme, like @code{basic}.  For basic authentication, the
+cdr of the pair will be the base64-encoded @address@hidden:@var{pass}}
+string.  For other authentication schemes, like @code{digest}, the cdr
+will be a key-value list of credentials.
address@hidden
+(parse-header 'authorization "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ=="
address@hidden (basic . "QWxhZGRpbjpvcGVuIHNlc2FtZQ==")
address@hidden example
address@hidden deftypevr
 
address@hidden from
-A string.
address@hidden {HTTP Header} List expect
+A list of expectations that a client has of a server.  The expectations
+are key-value lists.
address@hidden
+(parse-header 'expect "100-continue")
address@hidden ((100-continue))
address@hidden example
address@hidden deftypevr
 
address@hidden host
-A pair of the host, as a string, and the port, as an integer. If no port
-is given, port is @code{#f}.
address@hidden {HTTP Header} String from
+The email address of a user making an HTTP request.
address@hidden
+(parse-header 'from "bob@@example.com")
address@hidden "bob@@example.com"
address@hidden example
address@hidden deftypevr
 
address@hidden if-match
-Either the symbol @code{*}, or a list of entity tags (see above).
address@hidden {HTTP Header} Pair host
+The host for the resource being requested, as a hostname-port pair.  If
+no port is given, the port is @code{#f}.
address@hidden
+(parse-header 'host "gnu.org:80")
address@hidden ("gnu.org" . 80)
+(parse-header 'host "gnu.org")
address@hidden ("gnu.org" . #f)
address@hidden example
address@hidden deftypevr
 
address@hidden if-modified-since
-A SRFI-19 date.
address@hidden {HTTP Header} *|List if-match
+A set of etags, indicating that the request should proceed if and only
+if the etag of the resource is in that set.  Either the symbol @code{*},
+indicating any etag, or a list of entity tags.
address@hidden
+(parse-header 'if-match "*")
address@hidden *
+(parse-header 'if-match "asdfadf")
address@hidden (("asdfadf" . #t))
+(parse-header 'if-match W/"asdfadf")
address@hidden (("asdfadf" . #f))
address@hidden example
address@hidden deftypevr
 
address@hidden if-none-match
-Either the symbol @code{*}, or a list of entity tags (see above).
address@hidden {HTTP Header} Date if-modified-since
+Indicates that a response should proceed if and only if the resource has
+been modified since the given date.
address@hidden
+(parse-header if-modified-since "Tue, 15 Nov 1994 08:12:31 GMT")
address@hidden #<date ...>
address@hidden example
address@hidden deftypevr
 
address@hidden if-range
-Either an entity tag, or a SRFI-19 date.
address@hidden {HTTP Header} *|List if-none-match
+A set of etags, indicating that the request should proceed if and only
+if the etag of the resource is not in the set.  Either the symbol
address@hidden, indicating any etag, or a list of entity tags.
address@hidden
+(parse-header 'if-none-match "*")
address@hidden *
address@hidden example
address@hidden deftypevr
 
address@hidden if-unmodified-since
-A SRFI-19 date.
address@hidden {HTTP Header} ETag|Date if-range
+Indicates that the range request should proceed if and only if the
+resource matches a modification date or an etag.  Either an entity tag,
+or a SRFI-19 date.
address@hidden
+(parse-header 'if-range "\"original-etag\"")
address@hidden ("original-etag" . #t)
address@hidden example
address@hidden deftypevr
 
address@hidden max-forwards
-An exact non-negative integer.
address@hidden {HTTP Header} Date if-unmodified-since
+Indicates that a response should proceed if and only if the resource has
+not been modified since the given date.
address@hidden
+(parse-header 'if-not-modified-since "Tue, 15 Nov 1994 08:12:31 GMT")
address@hidden #<date ...>
address@hidden example
address@hidden deftypevr
 
address@hidden proxy-authorization
-A string.
address@hidden {HTTP Header} UInt max-forwards
+The maximum number of proxy or gateway hops that a request should be
+subject to.
address@hidden
+(parse-header 'max-forwards "10")
address@hidden 10
address@hidden example
address@hidden deftypevr
 
address@hidden range
-A pair whose car is the symbol @code{bytes}, and whose cdr is a list of
-pairs. Each element of the cdr indicates a range; the car is the first
-byte position and the cdr is the last byte position, as integers, or
address@hidden if not given.
address@hidden {HTTP Header} Pair proxy-authorization
+Authorization credentials for a proxy connection.  See the documentation
+for @code{authorization} above for more information on the format.
address@hidden
+(parse-header 'proxy-authorization "Digest foo=bar,baz=qux"
address@hidden (digest (foo . "bar") (baz . "qux"))
address@hidden example
address@hidden deftypevr
+
address@hidden {HTTP Header} Pair range
+A range request, indicating that the client wants only part of a
+resource.  The car of the pair is the symbol @code{bytes}, and the cdr
+is a list of pairs. Each element of the cdr indicates a range; the car
+is the first byte position and the cdr is the last byte position, as
+integers, or @code{#f} if not given.
address@hidden
+(parse-header 'range "bytes=10-30,50-")
address@hidden (bytes (10 . 30) (50 . #f))
address@hidden example
address@hidden deftypevr
 
address@hidden referer
-A URI.
address@hidden {HTTP Header} URI referer
+The URI of the resource that referred the user to this resource.  The
+name of the header is a misspelling, but we are stuck with it.
address@hidden
+(parse-header 'referer "http://www.gnu.org/";)
address@hidden #<uri ...>
address@hidden example
address@hidden deftypevr
 
address@hidden te
-A param list of transfer-codings.  The only known key is
address@hidden
address@hidden {HTTP Header} List te
+A list of transfer codings, expressed as key-value lists.  A common
+transfer coding is @code{trailers}.
address@hidden
+(parse-header 'te "trailers")
address@hidden ((trailers))
address@hidden example
address@hidden deftypevr
 
address@hidden user-agent
-A string.
address@hidden table
address@hidden {HTTP Header} String user-agent
+A string indicating the user agent making the request.  The
+specification defines a structured format for this header, but it is
+widely disregarded, so Guile does not attempt to parse strictly.
address@hidden
+(parse-header 'user-agent "Mozilla/5.0")
address@hidden "Mozilla/5.0"
address@hidden example
address@hidden deftypevr
 
 
 @subsubsection Response Headers
 
address@hidden @code
address@hidden accept-ranges
-A list of strings.
address@hidden {HTTP Header} List accept-ranges
+A list of range units that the server supports, as symbols.
address@hidden
+(parse-header 'accept-ranges "bytes")
address@hidden (bytes)
address@hidden example
address@hidden deftypevr
 
address@hidden age
-An exact, non-negative integer.
address@hidden {HTTP Header} UInt age
+The age of a cached response, in seconds.
address@hidden
+(parse-header 'age "3600")
address@hidden 3600
address@hidden example
address@hidden deftypevr
 
address@hidden etag
-An entity tag.
address@hidden {HTTP Header} ETag etag
+The entity-tag of the resource.
address@hidden
+(parse-header 'etag "\"foo\"")
address@hidden ("foo" . #t)
address@hidden example
address@hidden deftypevr
 
address@hidden location
-A URI.
address@hidden {HTTP Header} URI location
+A URI on which a request may be completed.  Used in combination with a
+redirecting status code to perform client-side redirection.
address@hidden
+(parse-header 'location "http://example.com/other";)
address@hidden #<uri ...>
address@hidden example
address@hidden deftypevr
 
address@hidden proxy-authenticate
-A string.
address@hidden {HTTP Header} List proxy-authenticate
+A list of challenges to a proxy, indicating the need for authentication.
address@hidden
+(parse-header 'proxy-authenticate "Basic realm=\"foo\"")
address@hidden ((basic (realm . "foo")))
address@hidden example
address@hidden deftypevr
 
address@hidden retry-after
-Either an exact, non-negative integer, or a SRFI-19 date.
address@hidden {HTTP Header} UInt|Date retry-after
+Used in combination with a server-busy status code, like 503, to
+indicate that a client should retry later.  Either a number of seconds,
+or a date.
address@hidden
+(parse-header 'retry-after "60")
address@hidden 60
address@hidden example
address@hidden deftypevr
 
address@hidden server
-A string.
address@hidden {HTTP Header} String server
+A string identifying the server.
address@hidden
+(parse-header 'server "My first web server")
address@hidden "My first web server"
address@hidden example
address@hidden deftypevr
 
address@hidden vary
-Either the symbol @code{*}, or a list of headers, with known headers
-parsed to symbols.
address@hidden {HTTP Header} *|List vary
+A set of request headers that were used in computing this response.
+Used to indicate that server-side content negotation was performed, for
+example in response to the @code{accept-language} header.  Can also be
+the symbol @code{*}, indicating that all headers were considered.
address@hidden
+(parse-header 'vary "Accept-Language, Accept")
address@hidden (accept-language accept)
address@hidden example
address@hidden deftypevr
 
address@hidden www-authenticate
-A string.
address@hidden table
address@hidden {HTTP Header} List www-authenticate
+A list of challenges to a user, indicating the need for authentication.
address@hidden
+(parse-header 'www-authenticate "Basic realm=\"foo\"")
address@hidden ((basic (realm . "foo")))
address@hidden example
address@hidden deftypevr
 
 
 @node Requests
diff --git a/examples/web/debug-sxml.scm b/examples/web/debug-sxml.scm
index 4e6afc2..724a9bd 100644
--- a/examples/web/debug-sxml.scm
+++ b/examples/web/debug-sxml.scm
@@ -30,8 +30,8 @@
                   (status 200)
                   (title default-title)
                   (doctype html5-doctype)
-                  (content-type-params '(("charset" . "utf-8")))
-                  (content-type "text/html")
+                  (content-type-params '((charset . "utf-8")))
+                  (content-type 'text/html)
                   (extra-headers '())
                   (sxml (and body (templatize #:title title #:body body))))
   (values (build-response
diff --git a/examples/web/hello.scm b/examples/web/hello.scm
index db17b9b..aa383c5 100644
--- a/examples/web/hello.scm
+++ b/examples/web/hello.scm
@@ -23,7 +23,7 @@
 ;; for us with a 200 OK status.
 ;;
 (define (handler request body)
-  (values '((content-type . ("text/plain")))
+  (values '((content-type . (text/plain)))
           "Hello, World!"))
 
 (run-server handler)
diff --git a/module/web/http.scm b/module/web/http.scm
index 422669a..8298505 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1,6 +1,6 @@
 ;;; 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
 ;; modify it under the terms of the GNU Lesser General Public
@@ -36,16 +36,14 @@
   #: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
@@ -72,39 +70,75 @@
 ;;; 
 
 
+(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)
+                          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 (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)
+  (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))
@@ -143,63 +177,40 @@ body was reached (i.e., a blank line)."
     (if (or (string-null? line)
             (string=? line "\r"))
         (values *eof* *eof*)
-        (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)
-  "Return the @var{header-decl} object registered for the given @var{name}.
-
address@hidden may be a symbol or a string.  Strings are mapped to headers
-in a case-insensitive fashion."
-  (if (string? name)
-      (hash-ref *declared-headers-by-name* (string-downcase name))
-      (hashq-ref *declared-headers* name)))
-
-(define (parse-header name val)
-  "Parse @var{val}, a string, with the parser for the header named @var{name}.
-
-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
-        (values (header-decl-sym decl)
-                ((header-decl-parser decl) val))
-        (values down val))))
+        (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)
   "Returns a true value iff @var{val} is a valid Scheme value for the
 header with name @var{sym}."
-  (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)
-  "Writes the given header name and value to @var{port}.  If @var{name}
-is a symbol, looks up a declared header and uses that writer. Otherwise
-the value is written using @var{display}."
-  (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))))))
+  (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 @var{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
@@ -247,7 +258,7 @@ ordered alist."
          (not (string-index str separators-without-slash)))))
 (define (parse-media-type str)
   (if (validate-media-type str)
-      str
+      (string->symbol str)
       (bad-header-component 'media-type str)))
 
 (define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
@@ -278,22 +289,15 @@ ordered alist."
   (write-list val port display ", "))
 
 (define (split-header-names str)
-  (map (lambda (f)
-         (or (and=> (lookup-header-decl f) header-decl-sym)
-             f))
-       (split-and-trim str)))
+  (map string->header (split-and-trim str)))
 
 (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)
   (write-list val port
               (lambda (x port)
-                (display (or (and (symbol? x)
-                                  (and=> (lookup-header-decl x)
-                                         header-decl-name))
-                             x)
-                         port))
+                (display (header->string x) port))
               ", "))
 
 (define (collect-escaped-string from start len escapes)
@@ -463,13 +467,11 @@ ordered alist."
 (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)
+  (string? val))
 
 (define (default-val-writer k val port)
   (if (or (string-index val #\;)
@@ -478,8 +480,8 @@ ordered alist."
       (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))
@@ -488,7 +490,8 @@ ordered alist."
                (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)))
@@ -501,14 +504,15 @@ ordered alist."
                                   (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
@@ -538,8 +542,8 @@ ordered alist."
 ;; 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))
@@ -547,7 +551,7 @@ ordered alist."
         (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
@@ -569,8 +573,9 @@ ordered alist."
                              (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))
@@ -580,19 +585,21 @@ ordered alist."
                        (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) #\,)
@@ -602,7 +609,7 @@ ordered alist."
             (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?))))
@@ -670,6 +677,108 @@ ordered alist."
 (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)) (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 ", "))
+
 
 
 
@@ -834,120 +943,96 @@ phrase\"."
 
 
 ;;;
-;;; 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-header-list-header 'scheme-indent-function 1)
-(define-syntax declare-header-list-header
-  (syntax-rules ()
-    ((_ sym name)
-     (declare-header sym
-       name
-       split-header-names list-of-header-names? write-header-list))))
-
-;; 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 (string->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? symbol? v))
+    (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))
 
 
 
@@ -980,26 +1065,15 @@ phrase\"."
 ;;      | 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)))
+       (parse-non-negative-integer v-str))
       ((private no-cache)
-       (if v-str
-           (cons k (split-header-names v-str))
-           k))
-      (else (if v-str (cons k v-str) k))))
-  default-kv-validator
+       (and v-str (split-header-names v-str)))
+      (else v-str)))
+  default-val-validator
   (lambda (k v port)
     (cond
      ((string? v) (display v port))
@@ -1017,40 +1091,31 @@ phrase\"."
 ;; 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-header-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
@@ -1059,8 +1124,7 @@ phrase\"."
 ;; received-by       = ( host [ ":" port ] ) | pseudonym
 ;; pseudonym         = token
 ;;
-(declare-header via
-  "Via"
+(declare-header! "Via"
   split-and-trim
   list-of-strings?
   write-list-of-strings
@@ -1077,8 +1141,7 @@ phrase\"."
 ;;                 ; 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)))
@@ -1149,33 +1212,27 @@ phrase\"."
 
 ;; 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
@@ -1186,8 +1243,7 @@ phrase\"."
 ;;                                | "*"
 ;; 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 #\/)))
@@ -1232,24 +1288,24 @@ phrase\"."
 
 ;; Content-Type = media-type
 ;;
-(declare-header content-type
-  "Content-Type"
+(declare-header! "Content-Type"
   (lambda (str)
     (let ((parts (string-split str #\;)))
       (cons (parse-media-type (car parts))
             (map (lambda (x)
                    (let ((eq (string-index x #\=)))
                      (if (and eq (= eq (string-rindex x #\=)))
-                         (cons (string-trim x char-whitespace? 0 eq)
+                         (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 (pair? val)
-         (string? (car val))
+         (symbol? (car val))
          (list-of? (cdr val)
                    (lambda (x)
-                     (and (pair? x) (string? (car x)) (string? (cdr x)))))))
+                     (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
   (lambda (val port)
     (display (car val) port)
     (if (pair? (cdr val)) 
@@ -1265,13 +1321,11 @@ phrase\"."
 
 ;; Expires = HTTP-date
 ;;
-(declare-date-header expires
-  "Expires")
+(declare-date-header! "Expires")
 
 ;; Last-Modified = HTTP-date
 ;;
-(declare-date-header last-modified
-  "Last-Modified")
+(declare-date-header! "Last-Modified")
 
 
 
@@ -1286,22 +1340,20 @@ phrase\"."
 ;; 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)))
+        (string? v)))
   (lambda (k v port)
     (if (eq? k 'q)
         (write-quality v port)
@@ -1309,28 +1361,24 @@ phrase\"."
 
 ;; 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
@@ -1338,24 +1386,17 @@ phrase\"."
 ;;                         *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
@@ -1376,23 +1417,19 @@ phrase\"."
 
 ;; 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))
@@ -1407,18 +1444,15 @@ phrase\"."
 
 ;; 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
@@ -1430,8 +1464,7 @@ phrase\"."
 ;; 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
@@ -1475,20 +1508,16 @@ phrase\"."
 
 ;; 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")
 
 
 
@@ -1500,38 +1529,31 @@ phrase\"."
 ;; 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)))
@@ -1546,13 +1568,11 @@ phrase\"."
 
 ;; 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 "*")
         '*
@@ -1566,6 +1586,4 @@ phrase\"."
 
 ;; WWW-Authenticate = 1#challenge
 ;;
-;; Hum.
-(declare-opaque-header www-authenticate
-  "WWW-Authenticate")
+(declare-challenge-list-header! "WWW-Authenticate")
diff --git a/module/web/request.scm b/module/web/request.scm
index adf1dd2..84bc36e 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -1,6 +1,6 @@
 ;;; 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
 ;; modify it under the terms of the GNU Lesser General Public
@@ -142,13 +142,9 @@
       (let ((h (car headers)))
         (if (pair? h)
             (let ((k (car h)) (v (cdr h)))
-              (if (symbol? k)
-                  (if (not (valid-header? 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)))
+              (if (valid-header? k v)
+                  (validate-headers (cdr headers))
+                  (bad-request "Bad value for header ~a: ~s" k v)))
             (bad-request "Header not a pair: ~a" h)))
       (if (not (null? headers))
           (bad-request "Headers not a list: ~a" headers))))
diff --git a/module/web/response.scm b/module/web/response.scm
index 7acde1e..f8a87a2 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -1,6 +1,6 @@
 ;;; 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
 ;; modify it under the terms of the GNU Lesser General Public
@@ -101,13 +101,9 @@
       (let ((h (car headers)))
         (if (pair? h)
             (let ((k (car h)) (v (cdr h)))
-              (if (symbol? k)
-                  (if (not (valid-header? 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)))
+              (if (valid-header? k v)
+                  (validate-headers (cdr headers))
+                  (bad-response "Bad value for header ~a: ~s" k v)))
             (bad-response "Header not a pair: ~a" h)))
       (if (not (null? headers))
           (bad-response "Headers not a list: ~a" headers))))
diff --git a/module/web/server.scm b/module/web/server.scm
index 042e4f1..02d01b0 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -1,6 +1,6 @@
 ;;; Web server
 
-;; 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
 ;; modify it under the terms of the GNU Lesser General Public
@@ -219,27 +219,27 @@ on the procedure being called at any particular time."
     (values response #vu8()))
    ((string? body)
     (let* ((type (response-content-type response
-                                        '("text/plain")))
-           (declared-charset (assoc-ref (cdr type) "charset"))
+                                        '(text/plain)))
+           (declared-charset (assq-ref (cdr type) 'charset))
            (charset (or declared-charset "utf-8")))
       (sanitize-response
        request
        (if declared-charset
            response
            (extend-response response 'content-type
-                            `(,@type ("charset" . ,charset))))
+                            `(,@type (charset . ,charset))))
        (encode-string body charset))))
    ((procedure? body)
     (let* ((type (response-content-type response
-                                        '("text/plain")))
-           (declared-charset (assoc-ref (cdr type) "charset"))
+                                        '(text/plain)))
+           (declared-charset (assq-ref (cdr type) 'charset))
            (charset (or declared-charset "utf-8")))
       (sanitize-response
        request
        (if declared-charset
            response
            (extend-response response 'content-type
-                            `(,@type ("charset" . ,charset))))
+                            `(,@type (charset . ,charset))))
        (call-with-encoded-output-string charset body))))
    ((bytevector? body)
     ;; check length; assert type; add other required fields?
@@ -370,7 +370,7 @@ For example, here is a simple \"Hello, World!\" server:
 
 @example
  (define (handler request body)
-   (values '((content-type . (\"text/plain\")))
+   (values '((content-type . (text/plain)))
            \"Hello, World!\"))
  (run-server handler)
 @end example
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 068523e..c191c6e 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -1,6 +1,6 @@
 ;;;; 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
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -41,9 +41,8 @@
   (syntax-rules ()
     ((_ sym str val)
      (pass-if (format #f "~a: ~s -> ~s" 'sym str val)
-       (call-with-values (lambda () (parse-header (symbol->string 'sym) str))
-         (lambda (k v)
-           (equal? v val)))))))
+       (equal? (parse-header 'sym str)
+               val)))))
 
 (define-syntax pass-if-any-error
   (syntax-rules ()
@@ -51,7 +50,7 @@
      (pass-if (format #f "~a: ~s -> any error" 'sym str)
        (% (catch #t
             (lambda ()
-              (parse-header (symbol->string 'sym) str)
+              (parse-header 'sym str)
               (abort (lambda () (error "expected exception"))))
             (lambda (k . args)
               #t))
@@ -64,7 +63,7 @@
      (pass-if (format #f "~a: ~s -> ~a error" 'sym str 'expected-component)
        (catch 'bad-header
          (lambda ()
-           (parse-header (symbol->string 'sym) str)
+           (parse-header 'sym str)
            (error "expected exception" 'expected-component))
          (lambda (k component arg)
            (if (or (not 'expected-component)
@@ -75,17 +74,17 @@
 (with-test-prefix "general headers"
 
   (pass-if-parse cache-control "no-transform" '(no-transform))
-  (pass-if-parse cache-control "no-transform,foo" '(no-transform "foo"))
+  (pass-if-parse cache-control "no-transform,foo" '(no-transform foo))
   (pass-if-parse cache-control "no-cache" '(no-cache))
   (pass-if-parse cache-control "no-cache=\"Authorization, Date\""
                  '((no-cache . (authorization date))))
   (pass-if-parse cache-control "private=\"Foo\""
-                 '((private . ("Foo"))))
+                 '((private . (foo))))
   (pass-if-parse cache-control "no-cache,max-age=10"
                  '(no-cache (max-age . 10)))
 
-  (pass-if-parse connection "close" '("close"))
-  (pass-if-parse connection "close, foo" '("close" "foo"))
+  (pass-if-parse connection "close" '(close))
+  (pass-if-parse connection "Content-Encoding" '(content-encoding))
 
   (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT"
                  (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
@@ -94,12 +93,12 @@
   (pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST")
 
   (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 "connection, bar" '(connection "bar"))
+  (pass-if-parse trailer "foo, bar" '(foo 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)))
 
   (pass-if-parse upgrade "qux" '("qux"))
 
@@ -115,8 +114,8 @@
                          "~a, ~d ~b ~Y ~H:~M:~S ~z")))))
 
 (with-test-prefix "entity headers"
-  (pass-if-parse allow "foo, bar" '("foo" "bar"))
-  (pass-if-parse content-encoding "qux, baz" '("qux" "baz"))
+  (pass-if-parse allow "foo, bar" '(foo bar))
+  (pass-if-parse content-encoding "qux, baz" '(qux baz))
   (pass-if-parse content-language "qux, baz" '("qux" "baz"))
   (pass-if-parse content-length "100" 100)
   (pass-if-parse content-length "0" 0)
@@ -126,8 +125,8 @@
   (pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *))
   (pass-if-parse content-range "bytes */*" '(bytes * *))
   (pass-if-parse content-range "bytes */30" '(bytes * 30))
-  (pass-if-parse content-type "foo/bar" '("foo/bar"))
-  (pass-if-parse content-type "foo/bar; baz=qux" '("foo/bar" ("baz" . "qux")))
+  (pass-if-parse content-type "foo/bar" '(foo/bar))
+  (pass-if-parse content-type "foo/bar; baz=qux" '(foo/bar (baz . "qux")))
   (pass-if-parse expires "Tue, 15 Nov 1994 08:12:31 GMT"
                  (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
                          "~a, ~d ~b ~Y ~H:~M:~S ~z"))
@@ -137,9 +136,9 @@
 
 (with-test-prefix "request headers"
   (pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1"
-                 '(("text/*" (q . 300))
-                   ("text/html" (q . 700))
-                   ("text/html" ("level" . "1"))))
+                 '((text/* (q . 300))
+                   (text/html (q . 700))
+                   (text/html (level . "1"))))
   (pass-if-parse accept-charset "iso-8859-5, unicode-1-1;q=0.8"
                  '((1000 . "iso-8859-5") (800 . "unicode-1-1")))
   (pass-if-parse accept-encoding "gzip;q=1.0, identity; q=0.5, *;q=0"
@@ -150,8 +149,11 @@
                  '((1000 . "da") (800 . "en-gb") (700 . "en")))
   ;; Allow nonstandard .2 to mean 0.2
   (pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb")))
-  (pass-if-parse authorization "foo" "foo")
-  (pass-if-parse expect "100-continue, foo" '((100-continue) ("foo")))
+  (pass-if-parse authorization "Basic foooo" '(basic . "foooo"))
+  (pass-if-parse authorization "Digest foooo" '(digest foooo))
+  (pass-if-parse authorization "Digest foo=bar,baz=qux"
+                 '(digest (foo . "bar") (baz . "qux")))
+  (pass-if-parse expect "100-continue, foo" '((100-continue) (foo)))
   (pass-if-parse from "address@hidden" "address@hidden")
   (pass-if-parse host "qux" '("qux" . #f))
   (pass-if-parse host "qux:80" '("qux" . 80))
@@ -173,7 +175,10 @@
                          "~a, ~d ~b ~Y ~H:~M:~S ~z"))
   (pass-if-parse max-forwards "10" 10)
   (pass-if-parse max-forwards "00" 0)
-  (pass-if-parse proxy-authorization "foo" "foo")
+  (pass-if-parse proxy-authorization "Basic foooo" '(basic . "foooo"))
+  (pass-if-parse proxy-authorization "Digest foooo" '(digest foooo))
+  (pass-if-parse proxy-authorization "Digest foo=bar,baz=qux"
+                 '(digest (foo . "bar") (baz . "qux")))
   (pass-if-parse range "bytes=10-20" '(bytes (10 . 20)))
   (pass-if-parse range "bytes=10-" '(bytes (10 . #f)))
   (pass-if-parse range "bytes=-20" '(bytes (#f . 20)))
@@ -181,25 +186,27 @@
   (pass-if-parse referer "http://foo/bar?baz";
                  (build-uri 'http #:host "foo" #:path "/bar" #:query "baz"))
   (pass-if-parse te "trailers" '((trailers)))
-  (pass-if-parse te "trailers,foo" '((trailers) ("foo")))
+  (pass-if-parse te "trailers,foo" '((trailers) (foo)))
   (pass-if-parse user-agent "guile" "guile"))
 
 
 ;; Response headers
 ;;
 (with-test-prefix "response headers"
-  (pass-if-parse accept-ranges "foo,bar" '("foo" "bar"))
+  (pass-if-parse accept-ranges "foo,bar" '(foo bar))
   (pass-if-parse age "30" 30)
   (pass-if-parse etag "\"foo\"" '("foo" . #t))
   (pass-if-parse etag "W/\"foo\"" '("foo" . #f))
   (pass-if-parse location "http://other-place";
                  (build-uri 'http #:host "other-place"))
-  (pass-if-parse proxy-authenticate "ho-hum" "ho-hum")
+  (pass-if-parse proxy-authenticate "Basic realm=\"guile\""
+                 '((basic (realm . "guile"))))
   (pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT"
                  (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
                          "~a, ~d ~b ~Y ~H:~M:~S ~z"))
   (pass-if-parse retry-after "20" 20)
   (pass-if-parse server "guile!" "guile!")
   (pass-if-parse vary "*" '*)
-  (pass-if-parse vary "foo, bar" '("foo" "bar"))
-  (pass-if-parse www-authenticate "secret" "secret"))
+  (pass-if-parse vary "foo, bar" '(foo bar))
+  (pass-if-parse www-authenticate "Basic realm=\"guile\""
+                 '((basic (realm . "guile")))))
diff --git a/test-suite/tests/web-request.test 
b/test-suite/tests/web-request.test
index 82759bd..32b99dd 100644
--- a/test-suite/tests/web-request.test
+++ b/test-suite/tests/web-request.test
@@ -1,6 +1,6 @@
 ;;;; web-request.test --- HTTP requests       -*- 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
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -61,12 +61,12 @@ Accept-Language: en-gb, en;q=0.9\r
        (request-headers r)
        '((host . ("localhost" . 8080))
          (user-agent . "Mozilla/5.0 (X11; U; Linux x86_64; en-us) 
AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2")
-         (accept . (("application/xml")
-                    ("application/xhtml+xml")
-                    ("text/html" (q . 900))
-                    ("text/plain" (q . 800))
-                    ("image/png")
-                    ("*/*" (q . 500))))
+         (accept . ((application/xml)
+                    (application/xhtml+xml)
+                    (text/html (q . 900))
+                    (text/plain (q . 800))
+                    (image/png)
+                    (*/* (q . 500))))
          (accept-encoding . ((1000 . "gzip")))
          (accept-language . ((1000 . "en-gb") (900 . "en"))))))
     
diff --git a/test-suite/tests/web-response.test 
b/test-suite/tests/web-response.test
index 7c94275..7e7331e 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -1,6 +1,6 @@
 ;;;; web-response.test --- HTTP responses       -*- 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
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -72,14 +72,14 @@ abcdefghijklmnopqrstuvwxyz0123456789")
        `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000"
                                 "~a, ~d ~b ~Y ~H:~M:~S ~z"))
          (server . "Apache/2.0.55")
-         (accept-ranges . ("bytes"))
+         (accept-ranges . (bytes))
          (cache-control . ((max-age . 543234)))
          (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000"
                                    "~a, ~d ~b ~Y ~H:~M:~S ~z"))
          (vary . (accept-encoding))
-         (content-encoding . ("gzip"))
+         (content-encoding . (gzip))
          (content-length . 36)
-         (content-type . ("text/html" ("charset" . "utf-8"))))))
+         (content-type . (text/html (charset . "utf-8"))))))
     
     (pass-if "write then read"
       (call-with-values
@@ -96,4 +96,4 @@ abcdefghijklmnopqrstuvwxyz0123456789")
           (responses-equal? r body r* body*))))
 
     (pass-if "by accessor"
-      (equal? (response-content-encoding r) '("gzip")))))
+      (equal? (response-content-encoding r) '(gzip)))))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]