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

;;; HTTP messages

;; Copyright (C)  2010, 2011, 2012 Free Software Foundation, Inc.

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA

;;; Commentary:
;;;
;;; This module has a number of routines to parse textual
;;; representations of HTTP data into native Scheme data structures.
;;;
;;; It tries to follow RFCs fairly strictly---the road to perdition
;;; being paved with compatibility hacks---though some allowances are
;;; made for not-too-divergent texts (like a quality of .2 which should
;;; be 0.2, etc).
;;;
;;; Code:

(define-module (web http)
  #:use-module ((srfi srfi-1) #:select (append-map! map!))
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:use-module (ice-9 rdelim)
  #:use-module (web uri)
  #:export (string->header
            header->string

            declare-header!
            known-header?
            header-parser
            header-validator
            header-writer

            read-header
            parse-header
            valid-header?
            write-header

            read-headers
            write-headers

            parse-http-method
            parse-http-version
            parse-request-uri

            read-request-line
            write-request-line
            read-response-line
            write-response-line))


;;; TODO
;;;
;;; Look at quality lists with more insight.
;;; Think about `accept' a bit more.
;;; 


(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 name parser validator writer multiple?)
  header-decl?
  (name header-decl-name)
  (parser header-decl-parser)
  (validator header-decl-validator)
  (writer header-decl-writer)
  (multiple? header-decl-multiple?))

;; sym -> header
(define *declared-headers* (make-hash-table))

(define (lookup-header-decl sym)
  (hashq-ref *declared-headers* sym))

(define* (declare-header! name
                          parser
                          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."
  (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" 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))
         (line (car pair))
         (delim (cdr pair)))
    (if (and (string? line) (char? delim))
        (let ((orig-len (string-length line)))
          (let lp ((len orig-len))
            (if (and (> len 0)
                     (char-whitespace? (string-ref line (1- len))))
                (lp (1- len))
                (if (= len orig-len)
                    line
                    (substring line 0 len)))))
        (bad-header '%read line))))

(define (read-continuation-line port val)
  (if (or (eqv? (peek-char port) #\space)
          (eqv? (peek-char port) #\tab))
      (read-continuation-line port
                              (string-append val
                                             (begin
                                               (read-line* port))))
      val))

(define *eof* (call-with-input-string "" read))

(define (read-header port)
  "Reads one HTTP header from @var{port}. Returns two values: the header
name and the parsed Scheme value. May raise an exception if the header
was known but the value was invalid.

Returns the end-of-file object for both values if the end of the message
body was reached (i.e., a blank line)."
  (let ((line (read-line* port)))
    (if (or (string-null? line)
            (string=? line "\r"))
        (values *eof* *eof*)
        (let* ((delim (or (string-index line #\:)
                          (bad-header '%read line)))
               (sym (string->header (substring line 0 delim))))
          (values
           sym
           (parse-header
            sym
            (read-continuation-line
             port
             (string-trim-both line char-whitespace? (1+ delim)))))))))

(define (parse-header sym val)
  "Parse @var{val}, a string, with the parser registered for the header
named @var{sym}.

Returns the parsed value.  If a parser was not found, the value is
returned as a string."
  ((header-parser sym) val))

(define (valid-header? sym val)
  "Returns a true value iff @var{val} is a valid Scheme value for the
header with name @var{sym}."
  (if (symbol? sym)
      ((header-validator sym) val)
      (error "header name not a symbol" sym)))

(define (write-header sym val port)
  "Writes the given header name and value to @var{port}.  If @var{sym}
is a known header, uses the specific writer registered for that header.
Otherwise the value is written using @code{display}."
  (display (header->string sym) port)
  (display ": " port)
  ((header-writer sym) val port)
  (display "\r\n" port))

(define (read-headers port)
  "Read an HTTP message from @var{port}, returning the headers as an
ordered alist."
  (let lp ((headers '()))
    (call-with-values (lambda () (read-header port))
      (lambda (k v)
        (if (eof-object? k)
            (reverse! headers)
            (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."
  (let lp ((headers headers))
    (if (pair? headers)
        (begin
          (write-header (caar headers) (cdar headers) port)
          (lp (cdr headers))))))


\f

;;;
;;; Utilities
;;;

(define (bad-header sym val)
  (throw 'bad-header sym val))
(define (bad-header-component sym val)
  (throw 'bad-header sym val))

(define (parse-opaque-string str)
  str)
(define (validate-opaque-string val)
  (string? val))
(define (write-opaque-string val port)
  (display val port))

(define separators-without-slash
  (string->char-set "[^][()<>@,;:\\\"?= \t]"))
(define (validate-media-type str)
  (let ((idx (string-index str #\/)))
    (and idx (= idx (string-rindex str #\/))
         (not (string-index str separators-without-slash)))))
(define (parse-media-type str)
  (if (validate-media-type str)
      (string->symbol str)
      (bad-header-component 'media-type str)))

(define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
  (let lp ((i start))
    (if (and (< i end) (char-whitespace? (string-ref str i)))
        (lp (1+ i))
        i)))

(define* (trim-whitespace str #:optional (start 0) (end (string-length str)))
  (let lp ((i end))
    (if (and (< start i) (char-whitespace? (string-ref str (1- i))))
        (lp (1- i))
        i)))

(define* (split-and-trim str #:optional (delim #\,)
                         (start 0) (end (string-length str)))
  (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))))
          (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
        '())))

(define (list-of-strings? val)
  (list-of? val string?))

(define (write-list-of-strings val port)
  (write-list val port display ", "))

(define (split-header-names str)
  (map string->header (split-and-trim str)))

(define (list-of-header-names? val)
  (list-of? val symbol?))

(define (write-header-list val port)
  (write-list val port
              (lambda (x port)
                (display (header->string x) port))
              ", "))

(define (collect-escaped-string from start len escapes)
  (let ((to (make-string len)))
    (let lp ((start start) (i 0) (escapes escapes))
      (if (null? escapes)
          (begin
            (substring-move! from start (+ start (- len i)) to i)
            to)
          (let* ((e (car escapes))
                 (next-start (+ start (- e i) 2)))
            (substring-move! from start (- next-start 2) to i)
            (string-set! to e (string-ref from (- next-start 1)))
            (lp next-start (1+ e) (cdr escapes)))))))

;; in incremental mode, returns two values: the string, and the index at
;; which the string ended
(define* (parse-qstring str #:optional
                        (start 0) (end (trim-whitespace str start))
                        #:key incremental?)
  (if (and (< start end) (eqv? (string-ref str start) #\"))
      (let lp ((i (1+ start)) (qi 0) (escapes '()))
        (if (< i end)
            (case (string-ref str i)
              ((#\\)
               (lp (+ i 2) (1+ qi) (cons qi escapes)))
              ((#\")
               (let ((out (collect-escaped-string str (1+ start) qi escapes)))
                 (if incremental?
                     (values out (1+ i))
                     (if (= (1+ i) end)
                         out
                         (bad-header-component 'qstring str)))))
              (else
               (lp (1+ i) (1+ qi) escapes)))
            (bad-header-component 'qstring str)))
      (bad-header-component 'qstring str)))

(define (write-list l port write-item delim)
  (if (pair? l)
      (let lp ((l l))
        (write-item (car l) port)
        (if (pair? (cdr l))
            (begin
              (display delim port)
              (lp (cdr l)))))))

(define (write-qstring str port)
  (display #\" port)
  (if (string-index str #\")
      ;; optimize me
      (write-list (string-split str #\") port display "\\\"")
      (display str port))
  (display #\" port))

(define* (parse-quality str #:optional (start 0) (end (string-length str)))
  (define (char->decimal c)
    (let ((i (- (char->integer c) (char->integer #\0))))
      (if (and (<= 0 i) (< i 10))
          i
          (bad-header-component 'quality str))))
  (cond
   ((not (< start end))
    (bad-header-component 'quality str))
   ((eqv? (string-ref str start) #\1)
    (if (or (string= str "1" start end)
            (string= str "1." start end)
            (string= str "1.0" start end)
            (string= str "1.00" start end)
            (string= str "1.000" start end))
        1000
        (bad-header-component 'quality str)))
   ((eqv? (string-ref str start) #\0)
    (if (or (string= str "0" start end)
            (string= str "0." start end))
        0
        (if (< 2 (- end start) 6)
            (let lp ((place 1) (i (+ start 4)) (q 0))
              (if (= i (1+ start))
                  (if (eqv? (string-ref str (1+ start)) #\.)
                      q
                      (bad-header-component 'quality str))
                  (lp (* 10 place) (1- i)
                      (if (< i end)
                          (+ q (* place (char->decimal (string-ref str i))))
                          q))))
            (bad-header-component 'quality str))))
   ;; Allow the nonstandard .2 instead of 0.2.
   ((and (eqv? (string-ref str start) #\.)
         (< 1 (- end start) 5))
    (let lp ((place 1) (i (+ start 3)) (q 0))
      (if (= i start)
          q
          (lp (* 10 place) (1- i)
              (if (< i end)
                  (+ q (* place (char->decimal (string-ref str i))))
                  q)))))
   (else
    (bad-header-component 'quality str))))

(define (valid-quality? q)
  (and (non-negative-integer? q) (<= q 1000)))

(define (write-quality q port)
  (define (digit->char d)
    (integer->char (+ (char->integer #\0) d)))
  (display (digit->char (modulo (quotient q 1000) 10)) port)
  (display #\. port)
  (display (digit->char (modulo (quotient q 100) 10)) port)
  (display (digit->char (modulo (quotient q 10) 10)) port)
  (display (digit->char (modulo q 10)) port))

(define (list-of? val pred)
  (or (null? val)
      (and (pair? val)
           (pred (car val))
           (list-of? (cdr val) pred))))

(define* (parse-quality-list str)
  (map (lambda (part)
         (cond
          ((string-rindex part #\;)
           => (lambda (idx)
                (let ((qpart (string-trim-both part char-whitespace? (1+ idx))))
                  (if (string-prefix? "q=" qpart)
                      (cons (parse-quality qpart 2)
                            (string-trim-both part char-whitespace? 0 idx))
                      (bad-header-component 'quality qpart)))))
          (else
           (cons 1000 (string-trim-both part char-whitespace?)))))
       (string-split str #\,)))

(define (validate-quality-list l)
  (list-of? l
            (lambda (elt)
              (and (pair? elt)
                   (valid-quality? (car elt))
                   (string? (cdr elt))))))

(define (write-quality-list l port)
  (write-list l port
              (lambda (x port)
                (let ((q (car x))
                      (str (cdr x)))
                  (display str port)
                  (if (< q 1000)
                      (begin
                        (display ";q=" port)
                        (write-quality q port)))))
              ","))

(define* (parse-non-negative-integer val #:optional (start 0)
                                     (end (string-length val)))
  (define (char->decimal c)
    (let ((i (- (char->integer c) (char->integer #\0))))
      (if (and (<= 0 i) (< i 10))
          i
          (bad-header-component 'non-negative-integer val))))
  (if (not (< start end))
      (bad-header-component 'non-negative-integer val)
      (let lp ((i start) (out 0))
        (if (< i end)
            (lp (1+ i)
                (+ (* out 10) (char->decimal (string-ref val i))))
            out))))

(define (non-negative-integer? code)
  (and (number? code) (>= code 0) (exact? code) (integer? code)))
                                    
(define (default-val-parser k val)
  val)

(define (default-val-validator k val)
  (or (not val) (string? val)))

(define (default-val-writer k val port)
  (if (or (string-index val #\;)
          (string-index val #\,)
          (string-index val #\"))
      (write-qstring val port)
      (display val port)))

(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))
        (reverse! out)
        (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)))
               (k (string->symbol
                   (substring str i (trim-whitespace str i delim)))))
          (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-str next-i)
              (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 (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-val-validator))
  (list-of? list
            (lambda (elt)
              (cond
               ((pair? elt)
                (let ((k (car elt))
                      (v (cdr elt)))
                  (and (symbol? k)
                       (valid? k v))))
               ((symbol? elt)
                (valid? elt #f))
               (else #f)))))

(define* (write-key-value-list list port #:optional
                               (val-writer default-val-writer) (delim ", "))
  (write-list
   list port
   (lambda (x port)
     (let ((k (if (pair? x) (car x) x))
           (v (if (pair? x) (cdr x) #f)))
       (display k port)
       (if v
           (begin
             (display #\= port)
             (val-writer k v port)))))
   delim))

;; param-component = token [ "=" (token | quoted-string) ] \
;;    *(";" token [ "=" (token | quoted-string) ])
;;
(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 ((k (string->symbol
                    (substring str i (trim-whitespace str i (or delim end)))))
                (delimc (and delim (string-ref str delim))))
            (case delimc
              ((#\=)
               (call-with-values
                   (lambda ()
                     (let ((i (skip-whitespace str (1+ delim) end)))
                       (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)
                                      end)))
                             (values (substring str i delim)
                                     delim)))))
                 (lambda (v-str next-i)
                   (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))
                       ((#\;)
                        (lp (skip-whitespace str (1+ i) end)
                            (cons x out)))
                       (else            ; including #\,
                        (values (reverse! (cons x out)) i)))))))
              ((#\;)
               (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 #\,
               (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
                           (val-parser default-val-parser)
                           (start 0) (end (string-length str)))
  (let lp ((i start) (out '()))
    (call-with-values
        (lambda () (parse-param-component str val-parser i end))
      (lambda (item i)
        (if (< i end)
            (if (eqv? (string-ref str i) #\,)
                (lp (skip-whitespace str (1+ i) end)
                    (cons item out))
                (bad-header-component 'param-list str))
            (reverse! (cons item out)))))))

(define* (validate-param-list list #:optional
                              (valid? default-val-validator))
  (list-of? list
            (lambda (elt)
              (key-value-list? elt valid?))))

(define* (write-param-list list port #:optional
                           (val-writer default-val-writer))
  (write-list
   list port
   (lambda (item port)
     (write-key-value-list item port val-writer ";"))
   ","))

(define-syntax string-match?
  (lambda (x)
    (syntax-case x ()
      ((_ str pat) (string? (syntax->datum #'pat))
       (let ((p (syntax->datum #'pat)))
         #`(let ((s str))
             (and
              (= (string-length s) #,(string-length p))
              #,@(let lp ((i 0) (tests '()))
                   (if (< i (string-length p))
                       (let ((c (string-ref p i)))
                         (lp (1+ i)
                             (case c
                               ((#\.)   ; Whatever.
                                tests)
                               ((#\d)   ; Digit.
                                (cons #`(char-numeric? (string-ref s #,i))
                                      tests))
                               ((#\a)   ; Alphabetic.
                                (cons #`(char-alphabetic? (string-ref s #,i))
                                      tests))
                               (else    ; Literal.
                                (cons #`(eqv? (string-ref s #,i) #,c)
                                      tests)))))
                       tests)))))))))

;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun"
;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"

(define (parse-month str start end)
  (define (bad)
    (bad-header-component 'month (substring str start end)))
  (if (not (= (- end start) 3))
      (bad)
      (let ((a (string-ref str (+ start 0)))
            (b (string-ref str (+ start 1)))
            (c (string-ref str (+ start 2))))
        (case a
          ((#\J)
           (case b
             ((#\a) (case c ((#\n) 1) (else (bad))))
             ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad))))
             (else (bad))))
          ((#\F)
           (case b
             ((#\e) (case c ((#\b) 2) (else (bad))))
             (else (bad))))
          ((#\M)
           (case b
             ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad))))
             (else (bad))))
          ((#\A)
           (case b
             ((#\p) (case c ((#\r) 4) (else (bad))))
             ((#\u) (case c ((#\g) 8) (else (bad))))
             (else (bad))))
          ((#\S)
           (case b
             ((#\e) (case c ((#\p) 9) (else (bad))))
             (else (bad))))
          ((#\O)
           (case b
             ((#\c) (case c ((#\t) 10) (else (bad))))
             (else (bad))))
          ((#\N)
           (case b
             ((#\o) (case c ((#\v) 11) (else (bad))))
             (else (bad))))
          ((#\D)
           (case b
             ((#\e) (case c ((#\c) 12) (else (bad))))
             (else (bad))))
          (else (bad))))))

;; RFC 822, updated by RFC 1123
;; 
;; Sun, 06 Nov 1994 08:49:37 GMT
;; 01234567890123456789012345678
;; 0         1         2
(define (parse-rfc-822-date str)
  ;; We could verify the day of the week but we don't.
  (cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT")
         (let ((date (parse-non-negative-integer str 5 7))
               (month (parse-month str 8 11))
               (year (parse-non-negative-integer str 12 16))
               (hour (parse-non-negative-integer str 17 19))
               (minute (parse-non-negative-integer str 20 22))
               (second (parse-non-negative-integer str 23 25)))
           (make-date 0 second minute hour date month year 0)))
        ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT")
         (let ((date (parse-non-negative-integer str 5 6))
               (month (parse-month str 7 10))
               (year (parse-non-negative-integer str 11 15))
               (hour (parse-non-negative-integer str 16 18))
               (minute (parse-non-negative-integer str 19 21))
               (second (parse-non-negative-integer str 22 24)))
           (make-date 0 second minute hour date month year 0)))
        (else
         (bad-header 'date str)         ; prevent tail call
         #f)))

;; RFC 850, updated by RFC 1036
;; Sunday, 06-Nov-94 08:49:37 GMT
;;        0123456789012345678901
;;        0         1         2
(define (parse-rfc-850-date str comma)
  ;; We could verify the day of the week but we don't.
  (let ((tail (substring str (1+ comma))))
    (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT"))
        (bad-header 'date str))
    (let ((date (parse-non-negative-integer tail 1 3))
          (month (parse-month tail 4 7))
          (year (parse-non-negative-integer tail 8 10))
          (hour (parse-non-negative-integer tail 11 13))
          (minute (parse-non-negative-integer tail 14 16))
          (second (parse-non-negative-integer tail 17 19)))
      (make-date 0 second minute hour date month
                 (let* ((now (date-year (current-date)))
                        (then (+ now year (- (modulo now 100)))))
                   (cond ((< (+ then 50) now) (+ then 100))
                         ((< (+ now 50) then) (- then 100))
                         (else then)))
                 0))))

;; ANSI C's asctime() format
;; Sun Nov  6 08:49:37 1994
;; 012345678901234567890123
;; 0         1         2
(define (parse-asctime-date str)
  (if (not (string-match? str "aaa aaa .d dd:dd:dd dddd"))
      (bad-header 'date str))
  (let ((date (parse-non-negative-integer
               str
               (if (eqv? (string-ref str 8) #\space) 9 8)
               10))
        (month (parse-month str 4 7))
        (year (parse-non-negative-integer str 20 24))
        (hour (parse-non-negative-integer str 11 13))
        (minute (parse-non-negative-integer str 14 16))
        (second (parse-non-negative-integer str 17 19)))
    (make-date 0 second minute hour date month year 0)))

(define (parse-date str)
  (if (string-suffix? " GMT" str)
      (let ((comma (string-index str #\,)))
        (cond ((not comma) (bad-header 'date str))
              ((= comma 3) (parse-rfc-822-date str))
              (else (parse-rfc-850-date str comma))))
      (parse-asctime-date str)))

(define (write-date date port)
  (define (display-digits n digits port)
    (define zero (char->integer #\0))
    (let lp ((tens (expt 10 (1- digits))))
      (if (> tens 0)
          (begin
            (display (integer->char (+ zero (modulo (truncate/ n tens) 10)))
                    port)
            (lp (floor/ tens 10))))))
  (let ((date (if (zero? (date-zone-offset date))
                  date
                  (time-tai->date (date->time-tai date) 0))))
    (display (case (date-week-day date)
               ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ")
               ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ")
               ((6) "Sat, ") (else (error "bad date" date)))
             port)
    (display-digits (date-day date) 2 port)
    (display (case (date-month date)
               ((1)  " Jan ") ((2)  " Feb ") ((3)  " Mar ")
               ((4)  " Apr ") ((5)  " May ") ((6)  " Jun ")
               ((7)  " Jul ") ((8)  " Aug ") ((9)  " Sep ")
               ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
               (else (error "bad date" date)))
             port)
    (display-digits (date-year date) 4 port)
    (display #\space port)
    (display-digits (date-hour date) 2 port)
    (display #\: port)
    (display-digits (date-minute date) 2 port)
    (display #\: port)
    (display-digits (date-second date) 2 port)
    (display " GMT" port)))

(define (parse-entity-tag val)
  (if (string-prefix? "W/" val)
      (cons (parse-qstring val 2) #f)
      (cons (parse-qstring val) #t)))

(define (entity-tag? val)
  (and (pair? val)
       (string? (car val))))

(define (write-entity-tag val port)
  (if (not (cdr val))
      (display "W/" port))
  (write-qstring (car val) port))

(define* (parse-entity-tag-list val #:optional
                                (start 0) (end (string-length val)))
  (let ((strong? (not (string-prefix? "W/" val 0 2 start end))))
    (call-with-values (lambda ()
                        (parse-qstring val (if strong? start (+ start 2))
                                       end #:incremental? #t))
      (lambda (tag next)
        (acons tag strong?
               (let ((next (skip-whitespace val next end)))
                  (if (< next end)
                      (if (eqv? (string-ref val next) #\,)
                          (parse-entity-tag-list
                           val
                           (skip-whitespace val (1+ next) end)
                           end)
                          (bad-header-component 'entity-tag-list val))
                      '())))))))

(define (entity-tag-list? val)
  (list-of? val entity-tag?))

(define (write-entity-tag-list val port)
  (write-list val port write-entity-tag  ", "))

;; credentials = auth-scheme #auth-param
;; auth-scheme = token
;; auth-param = token "=" ( token | quoted-string )
;;
;; That's what the spec says. In reality the Basic scheme doesn't have
;; k-v pairs, just one auth token, so we give that token as a string.
;;
(define* (parse-credentials str #:optional (val-parser default-val-parser)
                            (start 0) (end (string-length str)))
  (let* ((start (skip-whitespace str start end))
         (delim (or (string-index str char-whitespace? start end) end)))
    (if (= start end)
        (bad-header-component 'authorization str))
    (let ((scheme (string->symbol
                   (string-downcase (substring str start (or delim end))))))
      (case scheme
        ((basic)
         (let* ((start (skip-whitespace str delim end)))
           (if (< start end)
               (cons scheme (substring str start end))
               (bad-header-component 'credentials str))))
        (else
         (cons scheme (parse-key-value-list str default-val-parser delim end)))))))

(define (validate-credentials val)
  (and (pair? val) (symbol? (car val))
       (case (car val)
         ((basic) (string? (cdr val)))
         (else (key-value-list? (cdr val))))))

(define (write-credentials val port)
  (display (car val) port)
  (if (pair? (cdr val))
      (begin
        (display #\space port)
        (write-key-value-list (cdr val) port))))

;; challenges = 1#challenge
;; challenge = auth-scheme 1*SP 1#auth-param
;;
;; A pain to parse, as both challenges and auth params are delimited by
;; commas, and qstrings can contain anything. We rely on auth params
;; necessarily having "=" in them.
;;
(define* (parse-challenge str #:optional
                          (start 0) (end (string-length str)))
  (let* ((start (skip-whitespace str start end))
         (sp (string-index str #\space start end))
         (scheme (if sp
                     (string->symbol (string-downcase (substring str start sp)))
                     (bad-header-component 'challenge str))))
    (let lp ((i sp) (out (list scheme)))
      (if (not (< i end))
          (values (reverse! out) end)
          (let* ((i (skip-whitespace str i end))
                 (eq (string-index str #\= i end))
                 (comma (string-index str #\, i end))
                 (delim (min (or eq end) (or comma end)))
                 (token-end (trim-whitespace str i delim)))
            (if (string-index str #\space i token-end)
                (values (reverse! out) i)
                (let ((k (string->symbol (substring str i token-end))))
                  (call-with-values
                      (lambda ()
                        (if (and eq (or (not comma) (< eq comma)))
                            (let ((i (skip-whitespace str (1+ eq) end)))
                              (if (and (< i end) (eqv? (string-ref str i) #\"))
                                  (parse-qstring str i end #:incremental? #t)
                                  (values (substring
                                           str i
                                           (trim-whitespace str i
                                                            (or comma end)))
                                          (or comma end))))
                            (values #f delim)))
                    (lambda (v next-i)
                      (let ((i (skip-whitespace str next-i end)))
                        (if (or (= i end) (eqv? (string-ref str i) #\,))
                            (lp (1+ i) (cons (if v (cons k v) k) out))
                            (bad-header-component
                             'challenge
                             (substring str start end)))))))))))))

(define* (parse-challenges str #:optional (val-parser default-val-parser)
                           (start 0) (end (string-length str)))
  (let lp ((i start) (ret '()))
    (let ((i (skip-whitespace str i end)))
      (if (< i end)
          (call-with-values (lambda () (parse-challenge str i end))
            (lambda (challenge i)
              (lp i (cons challenge ret))))
          (reverse ret)))))

(define (validate-challenges val)
  (list-of? val (lambda (x)
                  (and (pair? x) (symbol? (car x))
                       (key-value-list? (cdr x))))))

(define (write-challenge val port)
  (display (car val) port)
  (display #\space port)
  (write-key-value-list (cdr val) port))

(define (write-challenges val port)
  (write-list val port write-challenge ", "))


\f

;;;
;;; Request-Line and Response-Line
;;;

;; Hmm.
(define (bad-request message . args)
  (throw 'bad-request message args))
(define (bad-response message . args)
  (throw 'bad-response message args))

(define *known-versions* '())

(define* (parse-http-version str #:optional (start 0) (end (string-length str)))
  "Parse an HTTP version from @var{str}, returning it as a major-minor
pair. For example, @code{HTTP/1.1} parses as the pair of integers,
@code{(1 . 1)}."
  (or (let lp ((known *known-versions*))
        (and (pair? known)
             (if (string= str (caar known) start end)
                 (cdar known)
                 (lp (cdr known)))))
      (let ((dot-idx (string-index str #\. start end)))
        (if (and (string-prefix? "HTTP/" str 0 5 start end)
                 dot-idx
                 (= dot-idx (string-rindex str #\. start end)))
            (cons (parse-non-negative-integer str (+ start 5) dot-idx)
                  (parse-non-negative-integer str (1+ dot-idx) end))
            (bad-header-component 'http-version (substring str start end))))))

(define (write-http-version val port)
  "Write the given major-minor version pair to @var{port}."
  (display "HTTP/" port)
  (display (car val) port)
  (display #\. port)
  (display (cdr val) port))

(for-each
 (lambda (v)
   (set! *known-versions*
         (acons v (parse-http-version v 0 (string-length v))
                *known-versions*)))
 '("HTTP/1.0" "HTTP/1.1"))


;; Request-URI = "*" | absoluteURI | abs_path | authority
;;
;; The `authority' form is only permissible for the CONNECT method, so
;; because we don't expect people to implement CONNECT, we save
;; ourselves the trouble of that case, and disallow the CONNECT method.
;;
(define* (parse-http-method str #:optional (start 0) (end (string-length str)))
  "Parse an HTTP method from @var{str}.  The result is an upper-case
symbol, like @code{GET}."
  (cond
   ((string= str "GET" start end) 'GET)
   ((string= str "HEAD" start end) 'HEAD)
   ((string= str "POST" start end) 'POST)
   ((string= str "PUT" start end) 'PUT)
   ((string= str "DELETE" start end) 'DELETE)
   ((string= str "OPTIONS" start end) 'OPTIONS)
   ((string= str "TRACE" start end) 'TRACE)
   (else (bad-request "Invalid method: ~a" (substring str start end)))))

(define* (parse-request-uri str #:optional (start 0) (end (string-length str)))
  "Parse a URI from an HTTP request line.  Note that URIs in requests do
not have to have a scheme or host name.  The result is a URI object."
  (cond
   ((= start end)
    (bad-request "Missing Request-URI"))
   ((string= str "*" start end)
    #f)
   ((eq? (string-ref str start) #\/)
    (let* ((q (string-index str #\? start end))
           (f (string-index str #\# start end))
           (q (and q (or (not f) (< q f)) q)))
      (build-uri 'http
                 #:path (substring str start (or q f end))
                 #:query (and q (substring str (1+ q) (or f end)))
                 #:fragment (and f (substring str (1+ f) end)))))
   (else
    (or (string->uri (substring str start end))
        (bad-request "Invalid URI: ~a" (substring str start end))))))

(define (read-request-line port)
  "Read the first line of an HTTP request from @var{port}, returning
three values: the method, the URI, and the version."
  (let* ((line (read-line* port))
         (d0 (string-index line char-whitespace?)) ; "delimiter zero"
         (d1 (string-rindex line char-whitespace?)))
    (if (and d0 d1 (< d0 d1))
        (values (parse-http-method line 0 d0)
                (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
                (parse-http-version line (1+ d1) (string-length line)))
        (bad-request "Bad Request-Line: ~s" line))))

(define (write-uri uri port)
  (if (uri-host uri)
      (begin
        (display (uri-scheme uri) port)
        (display "://" port)
        (if (uri-userinfo uri)
            (begin
              (display (uri-userinfo uri) port)
              (display #\@ port)))
        (display (uri-host uri) port)
        (let ((p (uri-port uri)))
          (if (and p (not (eqv? p 80)))
              (begin
                (display #\: port)
                (display p port))))))
  (let* ((path (uri-path uri))
         (len (string-length path)))
    (cond
     ((and (> len 0) (not (eqv? (string-ref path 0) #\/)))
      (bad-request "Non-absolute URI path: ~s" path))
     ((and (zero? len) (not (uri-host uri)))
      (bad-request "Empty path and no host for URI: ~s" uri))
     (else
      (display path port))))
  (if (uri-query uri)
      (begin
        (display #\? 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}."
  (display method port)
  (display #\space port)
  (let ((path (uri-path uri))
        (query (uri-query uri)))
    (if (not (string-null? path))
        (display path port))
    (if query
        (begin
          (display "?" port)
          (display query port)))
    (if (and (string-null? path)
             (not query))
        ;; Make sure we display something.
        (display "/" port)))
  (display #\space port)
  (write-http-version version port)
  (display "\r\n" port))

(define (read-response-line port)
  "Read the first line of an HTTP response from @var{port}, returning
three values: the HTTP version, the response code, and the \"reason
phrase\"."
  (let* ((line (read-line* port))
         (d0 (string-index line char-whitespace?)) ; "delimiter zero"
         (d1 (and d0 (string-index line char-whitespace?
                                   (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))
        (bad-response "Bad Response-Line: ~s" line))))

(define (write-response-line version code reason-phrase port)
  "Write the first line of an HTTP response to @var{port}."
  (write-http-version version port)
  (display #\space port)
  (display code port)
  (display #\space port)
  (display reason-phrase port)
  (display "\r\n" port))


\f

;;;
;;; Helpers for declaring headers
;;;

;; emacs: (put 'declare-header! 'scheme-indent-function 1)
;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
(define (declare-opaque-header! name)
  (declare-header! name
    parse-opaque-string validate-opaque-string write-opaque-string))

;; emacs: (put 'declare-date-header! 'scheme-indent-function 1)
(define (declare-date-header! name)
  (declare-header! name
    parse-date date? write-date))

;; emacs: (put 'declare-string-list-header! 'scheme-indent-function 1)
(define (declare-string-list-header! name)
  (declare-header! name
    split-and-trim list-of-strings? write-list-of-strings))

;; emacs: (put 'declare-symbol-list-header! 'scheme-indent-function 1)
(define (declare-symbol-list-header! name)
  (declare-header! name
    (lambda (str)
      (map string->symbol (split-and-trim str)))
    (lambda (v)
      (list-of? v symbol?))
    (lambda (v port)
      (write-list v port display ", "))))

;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1)
(define (declare-header-list-header! name)
  (declare-header! name
    split-header-names list-of-header-names? write-header-list))

;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1)
(define (declare-integer-header! name)
  (declare-header! name
    parse-non-negative-integer non-negative-integer? display))

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

;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1)
(define (declare-quality-list-header! name)
  (declare-header! name
    parse-quality-list validate-quality-list write-quality-list))

;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1)
(define* (declare-param-list-header! name #:optional
                                     (val-parser default-val-parser)
                                     (val-validator default-val-validator)
                                     (val-writer default-val-writer))
  (declare-header! name
    (lambda (str) (parse-param-list str val-parser))
    (lambda (val) (validate-param-list val val-validator))
    (lambda (val port) (write-param-list val port val-writer))))

;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1)
(define* (declare-key-value-list-header! name #:optional
                                         (val-parser default-val-parser)
                                         (val-validator default-val-validator)
                                         (val-writer default-val-writer))
  (declare-header! name
    (lambda (str) (parse-key-value-list str val-parser))
    (lambda (val) (key-value-list? val val-validator))
    (lambda (val port) (write-key-value-list val port val-writer))))

;; emacs: (put 'declare-entity-tag-list-header! 'scheme-indent-function 1)
(define (declare-entity-tag-list-header! name)
  (declare-header! name
    (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str)))
    (lambda (val) (or (eq? val '*) (entity-tag-list? val)))
    (lambda (val port)
      (if (eq? val '*)
          (display "*" port)
          (write-entity-tag-list val port)))))

;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1)
(define (declare-credentials-header! name)
  (declare-header! name
    parse-credentials validate-credentials write-credentials))

;; emacs: (put 'declare-challenge-list-header! 'scheme-indent-function 1)
(define (declare-challenge-list-header! name)
  (declare-header! name
    parse-challenges validate-challenges write-challenges))


\f

;;;
;;; General headers
;;;

;; Cache-Control   = 1#(cache-directive)
;; cache-directive = cache-request-directive | cache-response-directive
;; cache-request-directive =
;;        "no-cache"                          ; Section 14.9.1
;;      | "no-store"                          ; Section 14.9.2
;;      | "max-age" "=" delta-seconds         ; Section 14.9.3, 14.9.4
;;      | "max-stale" [ "=" delta-seconds ]   ; Section 14.9.3
;;      | "min-fresh" "=" delta-seconds       ; Section 14.9.3
;;      | "no-transform"                      ; Section 14.9.5
;;      | "only-if-cached"                    ; Section 14.9.4
;;      | cache-extension                     ; Section 14.9.6
;;  cache-response-directive =
;;        "public"                               ; Section 14.9.1
;;      | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1
;;      | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1
;;      | "no-store"                             ; Section 14.9.2
;;      | "no-transform"                         ; Section 14.9.5
;;      | "must-revalidate"                      ; Section 14.9.4
;;      | "proxy-revalidate"                     ; Section 14.9.4
;;      | "max-age" "=" delta-seconds            ; Section 14.9.3
;;      | "s-maxage" "=" delta-seconds           ; Section 14.9.3
;;      | cache-extension                        ; Section 14.9.6
;; cache-extension = token [ "=" ( token | quoted-string ) ]
;;
(declare-key-value-list-header! "Cache-Control"
  (lambda (k v-str)
    (case k
      ((max-age min-fresh s-maxage)
       (parse-non-negative-integer v-str))
      ((max-stale)
       (and v-str (parse-non-negative-integer v-str)))
      ((private no-cache)
       (and v-str (split-header-names v-str)))
      (else v-str)))
  (lambda (k v)
    (case k
      ((max-age min-fresh s-maxage)
       (non-negative-integer? v))
      ((max-stale)
       (or (not v) (non-negative-integer? v)))
      ((private no-cache)
       (or (not v) (list-of-header-names? v)))
      ((no-store no-transform only-if-cache must-revalidate proxy-revalidate)
       (not v))
      (else
       (or (not v) (string? v)))))
  (lambda (k v port)
    (cond
     ((string? v) (default-val-writer k v port))
     ((pair? v)
      (display #\" port)
      (write-header-list v port)
      (display #\" port))
     ((integer? v)
      (display v port))
     (else
      (bad-header-component 'cache-control v)))))

;; Connection = "Connection" ":" 1#(connection-token)
;; connection-token  = token
;; e.g.
;;     Connection: close, foo-header
;; 
(declare-header-list-header! "Connection")

;; Date  = "Date" ":" HTTP-date
;; e.g.
;;     Date: Tue, 15 Nov 1994 08:12:31 GMT
;;
(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")

;; Trailer  = "Trailer" ":" 1#field-name
;;
(declare-header-list-header! "Trailer")

;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding
;;
(declare-param-list-header! "Transfer-Encoding")

;; Upgrade = "Upgrade" ":" 1#product
;;
(declare-string-list-header! "Upgrade")

;; Via =  "Via" ":" 1#( received-protocol received-by [ comment ] )
;; received-protocol = [ protocol-name "/" ] protocol-version
;; protocol-name     = token
;; protocol-version  = token
;; received-by       = ( host [ ":" port ] ) | pseudonym
;; pseudonym         = token
;;
(declare-header! "Via"
  split-and-trim
  list-of-strings?
  write-list-of-strings
  #:multiple? #t)

;; Warning    = "Warning" ":" 1#warning-value
;;
;; warning-value = warn-code SP warn-agent SP warn-text
;;                                       [SP warn-date]
;;
;; warn-code  = 3DIGIT
;; warn-agent = ( host [ ":" port ] ) | pseudonym
;;                 ; the name or pseudonym of the server adding
;;                 ; the Warning header, for use in debugging
;; warn-text  = quoted-string
;; warn-date  = <"> HTTP-date <">
(declare-header! "Warning"
  (lambda (str)
    (let ((len (string-length str)))
      (let lp ((i (skip-whitespace str 0)))
        (let* ((idx1 (string-index str #\space i))
               (idx2 (string-index str #\space (1+ idx1))))
          (if (and idx1 idx2)
              (let ((code (parse-non-negative-integer str i idx1))
                    (agent (substring str (1+ idx1) idx2)))
                (call-with-values
                    (lambda () (parse-qstring str (1+ idx2) #:incremental? #t))
                  (lambda (text i)
                    (call-with-values
                        (lambda ()
                          (let ((c (and (< i len) (string-ref str i))))
                            (case c
                              ((#\space)
                               ;; we have a date.
                               (call-with-values
                                   (lambda () (parse-qstring str (1+ i)
                                                             #:incremental? #t))
                                 (lambda (date i)
                                   (values text (parse-date date) i))))
                              (else
                               (values text #f i)))))
                      (lambda (text date i)
                        (let ((w (list code agent text date))
                              (c (and (< i len) (string-ref str i))))
                          (case c
                            ((#f) (list w))
                            ((#\,) (cons w (lp (skip-whitespace str (1+ i)))))
                            (else (bad-header 'warning str))))))))))))))
  (lambda (val)
    (list-of? val
              (lambda (elt)
                (and (list? elt)
                     (= (length elt) 4)
                     (apply (lambda (code host text date)
                              (and (non-negative-integer? code) (< code 1000)
                                   (string? host)
                                   (string? text)
                                   (or (not date) (date? date))))
                            elt)))))
  (lambda (val port)
    (write-list
     val port
     (lambda (w port)
       (apply
        (lambda (code host text date)
          (display code port)
          (display #\space port)
          (display host port)
          (display #\space port)
          (write-qstring text port)
          (if date
              (begin
                (display #\space port)
                (write-date date port))))
        w))
     ", "))
  #:multiple? #t)


\f

;;;
;;; Entity headers
;;;

;; Allow = #Method
;;
(declare-symbol-list-header! "Allow")

;; Content-Encoding = 1#content-coding
;;
(declare-symbol-list-header! "Content-Encoding")

;; Content-Language = 1#language-tag
;;
(declare-string-list-header! "Content-Language")

;; Content-Length = 1*DIGIT
;;
(declare-integer-header! "Content-Length")

;; Content-Location = ( absoluteURI | relativeURI )
;;
(declare-uri-header! "Content-Location")

;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
;;
(declare-opaque-header! "Content-MD5")

;; Content-Range = content-range-spec
;; content-range-spec      = byte-content-range-spec
;; byte-content-range-spec = bytes-unit SP
;;                           byte-range-resp-spec "/"
;;                           ( instance-length | "*" )
;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos)
;;                                | "*"
;; instance-length           = 1*DIGIT
;;
(declare-header! "Content-Range"
  (lambda (str)
    (let ((dash (string-index str #\-))
          (slash (string-index str #\/)))
      (if (and (string-prefix? "bytes " str) slash)
          (list 'bytes
                (cond
                 (dash
                  (cons
                   (parse-non-negative-integer str 6 dash)
                   (parse-non-negative-integer str (1+ dash) slash)))
                 ((string= str "*" 6 slash)
                  '*)
                 (else
                  (bad-header 'content-range str)))
                (if (string= str "*" (1+ slash))
                    '*
                    (parse-non-negative-integer str (1+ slash))))
          (bad-header 'content-range str))))
  (lambda (val)
    (and (list? val) (= (length val) 3)
         (symbol? (car val))
         (let ((x (cadr val)))
           (or (eq? x '*)
               (and (pair? x)
                    (non-negative-integer? (car x))
                    (non-negative-integer? (cdr x)))))
         (let ((x (caddr val)))
           (or (eq? x '*)
               (non-negative-integer? x)))))
  (lambda (val port)
    (display (car val) port)
    (display #\space port)
    (if (eq? (cadr val) '*)
        (display #\* port)
        (begin
          (display (caadr val) port)
          (display #\- port)
          (display (caadr val) port)))
    (if (eq? (caddr val) '*)
        (display #\* port)
        (display (caddr val) port))))

;; Content-Type = media-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->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)
         (symbol? (car val))
         (list-of? (cdr val)
                   (lambda (x)
                     (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
  (lambda (val port)
    (display (car val) port)
    (if (pair? (cdr val)) 
       (begin
          (display ";" port)
          (write-list
           (cdr val) port
           (lambda (pair port)
             (display (car pair) port)
             (display #\= port)
             (display (cdr pair) port))
           ";")))))

;; Expires = HTTP-date
;;
(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT"))

(declare-header! "Expires"
  (lambda (str)
    (if (member str '("0" "-1"))
        *date-in-the-past*
        (parse-date str)))
  date?
  write-date)

;; Last-Modified = HTTP-date
;;
(declare-date-header! "Last-Modified")


\f

;;;
;;; Request headers
;;;

;; Accept = #( media-range [ accept-params ] )
;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) )
;;               *( ";" parameter )
;; accept-params = ";" "q" "=" qvalue *( accept-extension )
;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
;;
(declare-param-list-header! "Accept"
  ;; -> (type/subtype (sym-prop . str-val) ...) ...)
  ;;
  ;; with the exception of prop `q', in which case the val will be a
  ;; valid quality value
  ;;
  (lambda (k v)
    (if (eq? k 'q) 
        (parse-quality v)
        v))
  (lambda (k v)
    (if (eq? k 'q)
        (valid-quality? v)
        (or (not v) (string? v))))
  (lambda (k v port)
    (if (eq? k 'q)
        (write-quality v port)
        (default-val-writer k v port))))

;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] )
;;
(declare-quality-list-header! "Accept-Charset")

;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] )
;; codings = ( content-coding | "*" )
;;
(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")

;; Authorization = credentials
;; credentials = auth-scheme #auth-param
;; auth-scheme = token
;; auth-param = token "=" ( token | quoted-string )
;;
(declare-credentials-header! "Authorization")

;; Expect = 1#expectation
;; expectation = "100-continue" | expectation-extension
;; expectation-extension = token [ "=" ( token | quoted-string )
;;                         *expect-params ]
;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
;;
(declare-param-list-header! "Expect")

;; From = mailbox
;;
;; Should be an email address; we just pass on the string as-is.
;;
(declare-opaque-header! "From")

;; Host = host [ ":" port ]
;; 
(declare-header! "Host"
  (lambda (str)
    (let ((colon (string-index str #\:)))
      (if colon
          (cons (substring str 0 colon)
                (parse-non-negative-integer str (1+ colon)))
          (cons str #f))))
  (lambda (val)
    (and (pair? val)
         (string? (car val))
         (or (not (cdr val))
             (non-negative-integer? (cdr val)))))
  (lambda (val port)
    (display (car val) port)
    (if (cdr val)
        (begin
          (display #\: port)
          (display (cdr val) port)))))

;; If-Match = ( "*" | 1#entity-tag )
;;
(declare-entity-tag-list-header! "If-Match")

;; If-Modified-Since = HTTP-date
;;
(declare-date-header! "If-Modified-Since")

;; If-None-Match = ( "*" | 1#entity-tag )
;;
(declare-entity-tag-list-header! "If-None-Match")

;; If-Range = ( entity-tag | HTTP-date )
;;
(declare-header! "If-Range"
  (lambda (str)
    (if (or (string-prefix? "\"" str)
            (string-prefix? "W/" str))
        (parse-entity-tag str)
        (parse-date str)))
  (lambda (val)
    (or (date? val) (entity-tag? val)))
  (lambda (val port)
    (if (date? val)
        (write-date val port)
        (write-entity-tag val port))))

;; If-Unmodified-Since = HTTP-date
;;
(declare-date-header! "If-Unmodified-Since")

;; Max-Forwards = 1*DIGIT
;;
(declare-integer-header! "Max-Forwards")

;; Proxy-Authorization = credentials
;;
(declare-credentials-header! "Proxy-Authorization")

;; Range = "Range" ":" ranges-specifier
;; ranges-specifier = byte-ranges-specifier
;; byte-ranges-specifier = bytes-unit "=" byte-range-set
;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec )
;; byte-range-spec = first-byte-pos "-" [last-byte-pos]
;; first-byte-pos = 1*DIGIT
;; last-byte-pos = 1*DIGIT
;; suffix-byte-range-spec = "-" suffix-length
;; suffix-length = 1*DIGIT
;;
(declare-header! "Range"
  (lambda (str)
    (if (string-prefix? "bytes=" str)
        (cons
         'bytes
         (map (lambda (x)
                (let ((dash (string-index x #\-)))
                  (cond
                   ((not dash)
                    (bad-header 'range str))
                   ((zero? dash)
                    (cons #f (parse-non-negative-integer x 1)))
                   ((= dash (1- (string-length x)))
                    (cons (parse-non-negative-integer x 0 dash) #f))
                   (else
                    (cons (parse-non-negative-integer x 0 dash)
                          (parse-non-negative-integer x (1+ dash)))))))
              (string-split (substring str 6) #\,)))
        (bad-header 'range str)))
  (lambda (val)
    (and (pair? val)
         (symbol? (car val))
         (list-of? (cdr val)
                   (lambda (elt)
                     (and (pair? elt)
                          (let ((x (car elt)) (y (cdr elt)))
                            (and (or x y)
                                 (or (not x) (non-negative-integer? x))
                                 (or (not y) (non-negative-integer? y)))))))))
  (lambda (val port)
    (display (car val) port)
    (display #\= port)
    (write-list
     (cdr val) port
     (lambda (pair port)
       (if (car pair)
           (display (car pair) port))
       (display #\- port)
       (if (cdr pair)
           (display (cdr pair) port)))
     ",")))

;; Referer = ( absoluteURI | relativeURI )
;;
(declare-uri-header! "Referer")

;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
;;
(declare-param-list-header! "TE")

;; User-Agent = 1*( product | comment )
;;
(declare-opaque-header! "User-Agent")


\f

;;;
;;; Reponse headers
;;;

;; Accept-Ranges = acceptable-ranges
;; acceptable-ranges = 1#range-unit | "none"
;;
(declare-symbol-list-header! "Accept-Ranges")

;; Age = age-value
;; age-value = delta-seconds
;;
(declare-integer-header! "Age")

;; ETag = entity-tag
;;
(declare-header! "ETag"
  parse-entity-tag
  entity-tag?
  write-entity-tag)

;; Location = absoluteURI
;; 
(declare-uri-header! "Location")

;; Proxy-Authenticate = 1#challenge
;;
(declare-challenge-list-header! "Proxy-Authenticate")

;; Retry-After  = ( HTTP-date | delta-seconds )
;;
(declare-header! "Retry-After"
  (lambda (str)
    (if (and (not (string-null? str))
             (char-numeric? (string-ref str 0)))
        (parse-non-negative-integer str)
        (parse-date str)))
  (lambda (val)
    (or (date? val) (non-negative-integer? val)))
  (lambda (val port)
    (if (date? val)
        (write-date val port)
        (display val port))))

;; Server = 1*( product | comment )
;;
(declare-opaque-header! "Server")

;; Vary = ( "*" | 1#field-name )
;;
(declare-header! "Vary"
  (lambda (str)
    (if (equal? str "*")
        '*
        (split-header-names str)))
  (lambda (val)
    (or (eq? val '*) (list-of-header-names? val)))
  (lambda (val port)
    (if (eq? val '*)
        (display "*" port)
        (write-header-list val port))))

;; WWW-Authenticate = 1#challenge
;;
(declare-challenge-list-header! "WWW-Authenticate")