Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / module / web / http.scm

diff --git a/module/web/http.scm b/module/web/http.scm
index aa099fe..c79d57d 100644 (file)
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1,6 +1,6 @@
 ;;; HTTP messages
 
 ;;; HTTP messages
 

-;; Copyright (C)  2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012, 2013 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
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public


@@ -34,11 +34,15 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
   #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
   #:use-module (ice-9 rdelim)

+  #:use-module (ice-9 q)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (rnrs bytevectors)

   #:use-module (web uri)
   #:export (string->header
             header->string
 
             declare-header!
   #:use-module (web uri)
   #:export (string->header
             header->string
 
             declare-header!

+            declare-opaque-header!

             known-header?
             header-parser
             header-validator
             known-header?
             header-parser
             header-validator


@@ -59,18 +63,14 @@
             read-request-line
             write-request-line
             read-response-line
             read-request-line
             write-request-line
             read-response-line

-            write-response-line))
+            write-response-line

 
 

-
-;;; TODO
-;;;
-;;; Look at quality lists with more insight.
-;;; Think about `accept' a bit more.
-;;; 
+            make-chunked-input-port
+            make-chunked-output-port))

 
 
 (define (string->header name)
 
 
 (define (string->header name)

-  "Parse @var{name} to a symbolic header name."
+  "Parse NAME to a symbolic header name."

   (string->symbol (string-downcase name)))
 
 (define-record-type <header-decl>
   (string->symbol (string-downcase name)))
 
 (define-record-type <header-decl>


@@ -93,12 +93,7 @@
                           validator
                           writer
                           #:key multiple?)
                           validator
                           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."
+  "Declare a parser, validator, and writer for a given header."

   (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)
   (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)


@@ -106,34 +101,40 @@ port, and writes the value to the port."
       (error "bad header decl" name parser validator writer multiple?)))
 
 (define (header->string sym)
       (error "bad header decl" name parser validator writer multiple?)))
 
 (define (header->string sym)

-  "Return the string form for the header named @var{sym}."
+  "Return the string form for the header named SYM."

   (let ((decl (lookup-header-decl sym)))
     (if decl
         (header-decl-name decl)
         (string-titlecase (symbol->string sym)))))
 
 (define (known-header? 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}."
+  "Return ‘#t’ iff SYM is a known header, with associated
+parsers and serialization procedures."

   (and (lookup-header-decl sym) #t))
 
 (define (header-parser sym)
   (and (lookup-header-decl sym) #t))
 
 (define (header-parser sym)

-  "Returns a procedure to parse values for the given header."
+  "Return the value parser for headers named 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."

   (let ((decl (lookup-header-decl sym)))
     (if decl
         (header-decl-parser decl)
         (lambda (x) x))))
 
 (define (header-validator sym)
   (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."
+  "Return a predicate which returns ‘#t’ if the given value is valid
+for headers named SYM.  The default validator for unknown headers
+is ‘string?’."

   (let ((decl (lookup-header-decl sym)))
     (if decl
         (header-decl-validator decl)
         string?)))
 
 (define (header-writer sym)
   (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."
+  "Return a procedure that writes values for headers named SYM to a
+port.  The resulting procedure takes two arguments: a value and a port.
+The default writer is ‘display’."

   (let ((decl (lookup-header-decl sym)))
     (if decl
         (header-decl-writer decl)
   (let ((decl (lookup-header-decl sym)))
     (if decl
         (header-decl-writer decl)


@@ -166,7 +167,7 @@ port."
 (define *eof* (call-with-input-string "" read))
 
 (define (read-header port)
 (define *eof* (call-with-input-string "" read))
 
 (define (read-header port)

-  "Reads one HTTP header from @var{port}. Returns two values: the header
+  "Reads one HTTP header from PORT. Returns two values: the header

 name and the parsed Scheme value. May raise an exception if the header
 was known but the value was invalid.
 
 name and the parsed Scheme value. May raise an exception if the header
 was known but the value was invalid.
 


@@ -185,35 +186,31 @@ body was reached (i.e., a blank line)."
             sym
             (read-continuation-line
              port
             sym
             (read-continuation-line
              port

-             (string-trim-both line char-whitespace? (1+ delim)))))))))
+             (string-trim-both line char-set:whitespace (1+ delim)))))))))

 
 (define (parse-header sym val)
 
 (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."
+  "Parse VAL, a string, with the parser registered for the header
+named SYM.  Returns the parsed value."

   ((header-parser sym) val))
 
 (define (valid-header? sym val)
   ((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}."
+  "Returns a true value iff VAL is a valid Scheme value for the
+header with name SYM."

   (if (symbol? sym)
       ((header-validator sym) val)
       (error "header name not a symbol" sym)))
 
 (define (write-header sym val 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}."
+  "Write the given header name and value to PORT, using the writer
+from ‘header-writer’."

   (display (header->string sym) port)
   (display ": " port)
   ((header-writer sym) val port)
   (display "\r\n" port))
 
 (define (read-headers port)
   (display (header->string sym) port)
   (display ": " port)
   ((header-writer sym) val port)
   (display "\r\n" port))
 
 (define (read-headers port)

-  "Read an HTTP message from @var{port}, returning the headers as an
-ordered alist."
+  "Read the headers of an HTTP message from PORT, returning them
+as an ordered alist."

   (let lp ((headers '()))
     (call-with-values (lambda () (read-header port))
       (lambda (k v)
   (let lp ((headers '()))
     (call-with-values (lambda () (read-header port))
       (lambda (k v)


@@ -222,8 +219,8 @@ ordered alist."
             (lp (acons k v headers)))))))
 
 (define (write-headers headers port)
             (lp (acons k v headers)))))))
 
 (define (write-headers headers port)

-  "Write the given header alist to @var{port}.  Doesn't write the final
-\\r\\n, as the user might want to add another header."
+  "Write the given header alist to PORT.  Doesn't write the final
+@samp{\\r\\n}, as the user might want to add another header."

   (let lp ((headers headers))
     (if (pair? headers)
         (begin
   (let lp ((headers headers))
     (if (pair? headers)
         (begin


@@ -240,7 +237,22 @@ ordered alist."
 (define (bad-header sym val)
   (throw 'bad-header sym val))
 (define (bad-header-component sym val)
 (define (bad-header sym val)
   (throw 'bad-header sym val))
 (define (bad-header-component sym val)

-  (throw 'bad-header sym val))
+  (throw 'bad-header-component sym val))
+
+(define (bad-header-printer port key args default-printer)
+  (apply (case-lambda
+           ((sym val)
+            (format port "Bad ~a header: ~a\n" (header->string sym) val))
+           (_ (default-printer)))
+         args))
+(define (bad-header-component-printer port key args default-printer)
+  (apply (case-lambda
+           ((sym val)
+            (format port "Bad ~a header component: ~a\n" sym val))
+           (_ (default-printer)))
+         args))
+(set-exception-printer! 'bad-header bad-header-printer)
+(set-exception-printer! 'bad-header-component bad-header-component-printer)

 
 (define (parse-opaque-string str)
   str)
 
 (define (parse-opaque-string str)
   str)


@@ -277,7 +289,7 @@ ordered alist."
   (let lp ((i start))
     (if (< i end)
         (let* ((idx (string-index str delim i end))
   (let lp ((i start))
     (if (< i end)
         (let* ((idx (string-index str delim i end))

-               (tok (string-trim-both str char-whitespace? i (or idx end))))
+               (tok (string-trim-both str char-set:whitespace i (or idx end))))

           (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
         '())))
 
           (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
         '())))
 


@@ -420,13 +432,13 @@ ordered alist."
          (cond
           ((string-rindex part #\;)
            => (lambda (idx)
          (cond
           ((string-rindex part #\;)
            => (lambda (idx)

-                (let ((qpart (string-trim-both part char-whitespace? (1+ idx))))
+                (let ((qpart (string-trim-both part char-set:whitespace (1+ idx))))

                   (if (string-prefix? "q=" qpart)
                       (cons (parse-quality qpart 2)
                   (if (string-prefix? "q=" qpart)
                       (cons (parse-quality qpart 2)

-                            (string-trim-both part char-whitespace? 0 idx))
+                            (string-trim-both part char-set:whitespace 0 idx))

                       (bad-header-component 'quality qpart)))))
           (else
                       (bad-header-component 'quality qpart)))))
           (else

-           (cons 1000 (string-trim-both part char-whitespace?)))))
+           (cons 1000 (string-trim-both part char-set:whitespace)))))

        (string-split str #\,)))
 
 (define (validate-quality-list l)
        (string-split str #\,)))
 
 (define (validate-quality-list l)


@@ -541,15 +553,15 @@ ordered alist."
 ;; param-component = token [ "=" (token | quoted-string) ] \
 ;;    *(";" token [ "=" (token | quoted-string) ])
 ;;
 ;; param-component = token [ "=" (token | quoted-string) ] \
 ;;    *(";" token [ "=" (token | quoted-string) ])
 ;;

+(define param-delimiters (char-set #\, #\; #\=))
+(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;))

 (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))
         (values (reverse! out) end)
 (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))
         (values (reverse! out) end)

-        (let ((delim (string-index str
-                                   (lambda (c) (memq c '(#\, #\; #\=)))
-                                   i)))
+        (let ((delim (string-index str param-delimiters i)))

           (let ((k (string->symbol
                     (substring str i (trim-whitespace str i (or delim end)))))
                 (delimc (and delim (string-ref str delim))))
           (let ((k (string->symbol
                     (substring str i (trim-whitespace str i (or delim end)))))
                 (delimc (and delim (string-ref str delim))))


@@ -561,13 +573,8 @@ ordered alist."
                        (if (and (< i end) (eqv? (string-ref str i) #\"))
                            (parse-qstring str i end #:incremental? #t)
                            (let ((delim
                        (if (and (< i end) (eqv? (string-ref str i) #\"))
                            (parse-qstring str i end #:incremental? #t)
                            (let ((delim

-                                  (or (string-index
-                                       str
-                                       (lambda (c)
-                                         (or (eqv? c #\;)
-                                             (eqv? c #\,)
-                                             (char-whitespace? c)))
-                                       i end)
+                                  (or (string-index str param-value-delimiters
+                                                    i end)

                                       end)))
                              (values (substring str i delim)
                                      delim)))))
                                       end)))
                              (values (substring str i delim)
                                      delim)))))


@@ -790,7 +797,7 @@ ordered alist."
              port)
     (display-digits (date-day date) 2 port)
     (display (case (date-month date)
              port)
     (display-digits (date-day date) 2 port)
     (display (case (date-month date)

-               ((1)  " Jan ") ((2)  " Feb ") ((3)  " Ma ")
+               ((1)  " Jan ") ((2)  " Feb ") ((3)  " Mar ")

                ((4)  " Apr ") ((5)  " May ") ((6)  " Jun ")
                ((7)  " Jul ") ((8)  " Aug ") ((9)  " Sep ")
                ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
                ((4)  " Apr ") ((5)  " May ") ((6)  " Jun ")
                ((7)  " Jul ") ((8)  " Aug ") ((9)  " Sep ")
                ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")


@@ -853,7 +860,7 @@ ordered alist."
 (define* (parse-credentials str #:optional (val-parser default-val-parser)
                             (start 0) (end (string-length str)))
   (let* ((start (skip-whitespace str start end))
 (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)))
+         (delim (or (string-index str char-set:whitespace start end) end)))

     (if (= start end)
         (bad-header-component 'authorization str))
     (let ((scheme (string->symbol
     (if (= start end)
         (bad-header-component 'authorization str))
     (let ((scheme (string->symbol


@@ -964,9 +971,9 @@ ordered alist."
 (define *known-versions* '())
 
 (define* (parse-http-version str #:optional (start 0) (end (string-length str)))
 (define *known-versions* '())
 
 (define* (parse-http-version str #:optional (start 0) (end (string-length str)))

-  "Parse an HTTP version from @var{str}, returning it as a major-minor
-pair. For example, @code{HTTP/1.1} parses as the pair of integers,
-@code{(1 . 1)}."
+  "Parse an HTTP version from STR, returning it as a major-minor
+pair. For example, ‘HTTP/1.1’ parses as the pair of integers,
+‘(1 . 1)’."

   (or (let lp ((known *known-versions*))
         (and (pair? known)
              (if (string= str (caar known) start end)
   (or (let lp ((known *known-versions*))
         (and (pair? known)
              (if (string= str (caar known) start end)


@@ -981,7 +988,7 @@ pair. For example, @code{HTTP/1.1} parses as the pair of integers,
             (bad-header-component 'http-version (substring str start end))))))
 
 (define (write-http-version val port)
             (bad-header-component 'http-version (substring str start end))))))
 
 (define (write-http-version val port)

-  "Write the given major-minor version pair to @var{port}."
+  "Write the given major-minor version pair to PORT."

   (display "HTTP/" port)
   (display (car val) port)
   (display #\. port)
   (display "HTTP/" port)
   (display (car val) port)
   (display #\. port)


@@ -1002,8 +1009,8 @@ pair. For example, @code{HTTP/1.1} parses as the pair of integers,
 ;; ourselves the trouble of that case, and disallow the CONNECT method.
 ;;
 (define* (parse-http-method str #:optional (start 0) (end (string-length str)))
 ;; ourselves the trouble of that case, and disallow the CONNECT method.
 ;;
 (define* (parse-http-method str #:optional (start 0) (end (string-length str)))

-  "Parse an HTTP method from @var{str}.  The result is an upper-case
-symbol, like @code{GET}."
+  "Parse an HTTP method from STR.  The result is an upper-case
+symbol, like ‘GET’."

   (cond
    ((string= str "GET" start end) 'GET)
    ((string= str "HEAD" start end) 'HEAD)
   (cond
    ((string= str "GET" start end) 'GET)
    ((string= str "HEAD" start end) 'HEAD)


@@ -1035,11 +1042,11 @@ not have to have a scheme or host name.  The result is a URI object."
         (bad-request "Invalid URI: ~a" (substring str start end))))))
 
 (define (read-request-line port)
         (bad-request "Invalid URI: ~a" (substring str start end))))))
 
 (define (read-request-line port)

-  "Read the first line of an HTTP request from @var{port}, returning
+  "Read the first line of an HTTP request from PORT, returning

 three values: the method, the URI, and the version."
   (let* ((line (read-line* port))
 three values: the method, the URI, and the version."
   (let* ((line (read-line* port))

-         (d0 (string-index line char-whitespace?)) ; "delimiter zero"
-         (d1 (string-rindex line char-whitespace?)))
+         (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+         (d1 (string-rindex line char-set:whitespace)))

     (if (and d0 d1 (< d0 d1))
         (values (parse-http-method line 0 d0)
                 (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
     (if (and d0 d1 (< d0 d1))
         (values (parse-http-method line 0 d0)
                 (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)


@@ -1076,7 +1083,7 @@ three values: the method, the URI, and the version."
         (display (uri-query uri) port))))
 
 (define (write-request-line method uri version port)
         (display (uri-query uri) port))))
 
 (define (write-request-line method uri version port)

-  "Write the first line of an HTTP request to @var{port}."
+  "Write the first line of an HTTP request to PORT."

   (display method port)
   (display #\space port)
   (let ((path (uri-path uri))
   (display method port)
   (display #\space port)
   (let ((path (uri-path uri))


@@ -1096,22 +1103,22 @@ three values: the method, the URI, and the version."
   (display "\r\n" port))
 
 (define (read-response-line port)
   (display "\r\n" port))
 
 (define (read-response-line port)

-  "Read the first line of an HTTP response from @var{port}, returning
+  "Read the first line of an HTTP response from PORT, returning

 three values: the HTTP version, the response code, and the \"reason
 phrase\"."
   (let* ((line (read-line* port))
 three values: the HTTP version, the response code, and the \"reason
 phrase\"."
   (let* ((line (read-line* port))

-         (d0 (string-index line char-whitespace?)) ; "delimiter zero"
-         (d1 (and d0 (string-index line char-whitespace?
+         (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+         (d1 (and d0 (string-index line char-set:whitespace

                                    (skip-whitespace line d0)))))
     (if (and d0 d1)
         (values (parse-http-version line 0 d0)
                 (parse-non-negative-integer line (skip-whitespace line d0 d1)
                                             d1)
                                    (skip-whitespace line d0)))))
     (if (and d0 d1)
         (values (parse-http-version line 0 d0)
                 (parse-non-negative-integer line (skip-whitespace line d0 d1)
                                             d1)

-                (string-trim-both line char-whitespace? d1))
+                (string-trim-both line char-set:whitespace d1))

         (bad-response "Bad Response-Line: ~s" line))))
 
 (define (write-response-line version code reason-phrase port)
         (bad-response "Bad Response-Line: ~s" line))))
 
 (define (write-response-line version code reason-phrase port)

-  "Write the first line of an HTTP response to @var{port}."
+  "Write the first line of an HTTP response to PORT."

   (write-http-version version port)
   (display #\space port)
   (display code port)
   (write-http-version version port)
   (display #\space port)
   (display code port)


@@ -1129,6 +1136,8 @@ phrase\"."
 ;; emacs: (put 'declare-header! 'scheme-indent-function 1)
 ;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
 (define (declare-opaque-header! name)
 ;; emacs: (put 'declare-header! 'scheme-indent-function 1)
 ;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
 (define (declare-opaque-header! name)

+  "Declares a given header as \"opaque\", meaning that its value is not
+treated specially, and is just returned as a plain string."

   (declare-header! name
     parse-opaque-string validate-opaque-string write-opaque-string))
 
   (declare-header! name
     parse-opaque-string validate-opaque-string write-opaque-string))
 


@@ -1166,6 +1175,15 @@ phrase\"."
 (define (declare-uri-header! name)
   (declare-header! name
     (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
 (define (declare-uri-header! name)
   (declare-header! name
     (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))

+    (@@ (web uri) absolute-uri?)
+    write-uri))
+
+;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
+(define (declare-relative-uri-header! name)
+  (declare-header! name
+    (lambda (str)
+      (or ((@@ (web uri) string->uri*) str)
+          (bad-header-component 'uri str)))

     uri?
     write-uri))
 
     uri?
     write-uri))
 


@@ -1282,9 +1300,19 @@ phrase\"."
 ;; Connection = "Connection" ":" 1#(connection-token)
 ;; connection-token  = token
 ;; e.g.
 ;; Connection = "Connection" ":" 1#(connection-token)
 ;; connection-token  = token
 ;; e.g.

-;;     Connection: close, foo-header
+;;     Connection: close, Foo-Header

 ;; 
 ;; 

-(declare-header-list-header! "Connection")
+(declare-header! "Connection"
+  split-header-names
+  list-of-header-names?
+  (lambda (val port)
+    (write-list val port
+                (lambda (x port)
+                  (display (if (eq? x 'close)
+                               "close"
+                               (header->string x))
+                           port))
+                ", ")))

 
 ;; Date  = "Date" ":" HTTP-date
 ;; e.g.
 
 ;; Date  = "Date" ":" HTTP-date
 ;; e.g.


@@ -1421,7 +1449,7 @@ phrase\"."
 
 ;; Content-Location = ( absoluteURI | relativeURI )
 ;;
 
 ;; Content-Location = ( absoluteURI | relativeURI )
 ;;

-(declare-uri-header! "Content-Location")
+(declare-relative-uri-header! "Content-Location")

 
 ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
 ;;
 
 ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
 ;;


@@ -1488,9 +1516,10 @@ phrase\"."
             (map (lambda (x)
                    (let ((eq (string-index x #\=)))
                      (if (and eq (= eq (string-rindex x #\=)))
             (map (lambda (x)
                    (let ((eq (string-index x #\=)))
                      (if (and eq (= eq (string-rindex x #\=)))

-                         (cons (string->symbol
-                                (string-trim x char-whitespace? 0 eq))
-                               (string-trim-right x char-whitespace? (1+ eq)))
+                         (cons
+                          (string->symbol
+                           (string-trim x char-set:whitespace 0 eq))
+                          (string-trim-right x char-set:whitespace (1+ eq)))

                          (bad-header 'content-type str))))
                  (cdr parts)))))
   (lambda (val)
                          (bad-header 'content-type str))))
                  (cdr parts)))))
   (lambda (val)


@@ -1514,7 +1543,15 @@ phrase\"."
 
 ;; Expires = HTTP-date
 ;;
 
 ;; Expires = HTTP-date
 ;;

-(declare-date-header! "Expires")
+(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT"))
+
+(declare-header! "Expires"
+  (lambda (str)
+    (if (member str '("0" "-1"))
+        *date-in-the-past*
+        (parse-date str)))
+  date?
+  write-date)

 
 ;; Last-Modified = HTTP-date
 ;;
 
 ;; Last-Modified = HTTP-date
 ;;


@@ -1701,7 +1738,7 @@ phrase\"."
 
 ;; Referer = ( absoluteURI | relativeURI )
 ;;
 
 ;; Referer = ( absoluteURI | relativeURI )
 ;;

-(declare-uri-header! "Referer")
+(declare-relative-uri-header! "Referer")

 
 ;; TE = #( t-codings )
 ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
 
 ;; TE = #( t-codings )
 ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )


@@ -1780,3 +1817,99 @@ phrase\"."
 ;; WWW-Authenticate = 1#challenge
 ;;
 (declare-challenge-list-header! "WWW-Authenticate")
 ;; WWW-Authenticate = 1#challenge
 ;;
 (declare-challenge-list-header! "WWW-Authenticate")

+
+
+;; Chunked Responses
+(define (read-chunk-header port)
+  (let* ((str (read-line port))
+         (extension-start (string-index str (lambda (c) (or (char=? c #\;)
+                                                       (char=? c #\return)))))
+         (size (string->number (if extension-start ; unnecessary?
+                                   (substring str 0 extension-start)
+                                   str)
+                               16)))
+    size))
+
+(define (read-chunk port)
+  (let ((size (read-chunk-header port)))
+    (read-chunk-body port size)))
+
+(define (read-chunk-body port size)
+  (let ((bv (get-bytevector-n port size)))
+    (get-u8 port)                       ; CR
+    (get-u8 port)                       ; LF
+    bv))
+
+(define* (make-chunked-input-port port #:key (keep-alive? #f))
+  "Returns a new port which translates HTTP chunked transfer encoded
+data from PORT into a non-encoded format. Returns eof when it has
+read the final chunk from PORT. This does not necessarily mean
+that there is no more data on PORT. When the returned port is
+closed it will also close PORT, unless the KEEP-ALIVE? is true."
+  (define (next-chunk)
+    (read-chunk port))
+  (define finished? #f)
+  (define (close)
+    (unless keep-alive?
+      (close-port port)))
+  (define buffer #vu8())
+  (define buffer-size 0)
+  (define buffer-pointer 0)
+  (define (read! bv idx to-read)
+    (define (loop to-read num-read)
+      (cond ((or finished? (zero? to-read))
+             num-read)
+            ((<= to-read (- buffer-size buffer-pointer))
+             (bytevector-copy! buffer buffer-pointer
+                               bv (+ idx num-read)
+                               to-read)
+             (set! buffer-pointer (+ buffer-pointer to-read))
+             (loop 0 (+ num-read to-read)))
+            (else
+             (let ((n (- buffer-size buffer-pointer)))
+               (bytevector-copy! buffer buffer-pointer
+                                 bv (+ idx num-read)
+                                 n)
+               (set! buffer (next-chunk))
+               (set! buffer-pointer 0)
+               (set! buffer-size (bytevector-length buffer))
+               (set! finished? (= buffer-size 0))
+               (loop (- to-read n)
+                     (+ num-read n))))))
+    (loop to-read 0))
+  (make-custom-binary-input-port "chunked input port" read! #f #f close))
+
+(define* (make-chunked-output-port port #:key (keep-alive? #f))
+  "Returns a new port which translates non-encoded data into a HTTP
+chunked transfer encoded data and writes this to PORT. Data
+written to this port is buffered until the port is flushed, at which
+point it is all sent as one chunk. Take care to close the port when
+done, as it will output the remaining data, and encode the final zero
+chunk. When the port is closed it will also close PORT, unless
+KEEP-ALIVE? is true."
+  (define (q-for-each f q)
+    (while (not (q-empty? q))
+      (f (deq! q))))
+  (define queue (make-q))
+  (define (put-char c)
+    (enq! queue c))
+  (define (put-string s)
+    (string-for-each (lambda (c) (enq! queue c))
+                     s))
+  (define (flush)
+    ;; It is important that we do _not_ write a chunk if the queue is
+    ;; empty, since it will be treated as the final chunk.
+    (unless (q-empty? queue)
+      (let ((len (q-length queue)))
+        (display (number->string len 16) port)
+        (display "\r\n" port)
+        (q-for-each (lambda (elem) (write-char elem port))
+                    queue)
+        (display "\r\n" port))))
+  (define (close)
+    (flush)
+    (display "0\r\n" port)
+    (force-output port)
+    (unless keep-alive?
+      (close-port port)))
+  (make-soft-port (vector put-char put-string flush #f close) "w"))