(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 (validate-opaque-string val)
  (string? val))
(define (write-opaque-string val port)
  (put-string port val))

(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)
  (unless (validate-media-type str)
    (bad-header-component 'media-type str))
  (string->symbol 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-set: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)
  (put-list port val put-string ", "))

(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)
  (put-list port val
            (lambda (port x)
              (put-string port (header->string x)))
            ", "))

(define (collect-escaped-string from start len escapes)
  (let ((to (make-string len)))
    (let lp ((start start) (i 0) (escapes escapes))
      (match escapes
        (()
         (substring-move! from start (+ start (- len i)) to i)
         to)
        ((e . escapes)
         (let ((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) 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?)
  (unless (and (< start end) (eqv? (string-ref str start) #\"))
    (bad-header-component 'qstring str))
  (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)))
             (cond
              (incremental? (values out (1+ i)))
              ((= (1+ i) end) out)
              (else (bad-header-component 'qstring str)))))
          (else
           (lp (1+ i) (1+ qi) escapes)))
        (bad-header-component 'qstring str))))

(define (put-list port items put-item delim)
  (match items
    (() (values))
    ((item . items)
     (put-item port item)
     (let lp ((items items))
       (match items
         (() (values))
         ((item . items)
          (put-string port delim)
          (put-item port item)
          (lp items)))))))

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

(define* (parse-quality str #:optional (start 0) (end (string-length str)))
  (define (char->decimal c)
    (let ((i (- (char->integer c) (char->integer #\0))))
      (unless (and (<= 0 i) (< i 10))
        (bad-header-component 'quality str))
      i))
  (cond
   ((not (< start end))
    (bad-header-component 'quality str))
   ((eqv? (string-ref str start) #\1)
    (unless (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))
      (bad-header-component 'quality str))
    1000)
   ((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)))
  (put-char port (digit->char (modulo (quotient q 1000) 10)))
  (put-char port #\.)
  (put-char port (digit->char (modulo (quotient q 100) 10)))
  (put-char port (digit->char (modulo (quotient q 10) 10)))
  (put-char port (digit->char (modulo q 10))))

(define (list-of? val pred)
  (match val
    (((? pred) ...) #t)
    (_ #f)))

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

(define (validate-quality-list l)
  (match l
    ((((? valid-quality?) . (? string?)) ...) #t)
    (_ #f)))

(define (write-quality-list l port)
  (put-list port l
            (lambda (port x)
              (let ((q (car x))
                    (str (cdr x)))
                (put-string port str)
                (when (< q 1000)
                  (put-string port ";q=")
                  (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))))
      (unless (and (<= 0 i) (< i 10))
        (bad-header-component 'non-negative-integer val))
      i))
  (unless (< 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)
      (put-string port val)))

(define* (parse-key-value-list str #:optional
                               (val-parser default-val-parser)
                               (start 0) (end (string-length str)))
  (let lp ((i start))
    (if (not (< i 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)))
               (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)))
                (unless (or (= i end) (eqv? (string-ref str i) #\,))
                  (bad-header-component 'key-value-list
                                        (substring str start end)))
                (cons (if v (cons k v) k)
                      (lp (1+ i))))))))))

(define* (key-value-list? list #:optional
                          (valid? default-val-validator))
  (list-of? list
            (lambda (elt)
              (match elt
                (((? symbol? k) . v) (valid? k v))
                ((? symbol? k) (valid? k #f))
                (_ #f)))))

(define* (write-key-value-list list port #:optional
                               (val-writer default-val-writer) (delim ", "))
  (put-list
   port list
   (lambda (port x)
     (match x
       ((k . #f)
        (put-symbol port k))
       ((k . v)
        (put-symbol port k)
        (put-char port #\=)
        (val-writer k v port))
       (k
        (put-symbol port k))))
   delim))

;; 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)
        (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))))
            (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 param-value-delimiters
                                                    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))
  (put-list
   port list
   (lambda (port item)
     (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))))))

;; "GMT" | "+" 4DIGIT | "-" 4DIGIT
;;
;; RFC 2616 requires date values to use "GMT", but recommends accepting
;; the others as they are commonly generated by e.g. RFC 822 sources.
(define (parse-zone-offset str start)
  (let ((s (substring str start)))
    (define (bad)
      (bad-header-component 'zone-offset s))
    (cond
     ((string=? s "GMT")
      0)
     ((string=? s "UTC")
      0)
     ((string-match? s ".dddd")
      (let ((sign (case (string-ref s 0)
                    ((#\+) +1)
                    ((#\-) -1)
                    (else (bad))))
            (hours (parse-non-negative-integer s 1 3))
            (minutes (parse-non-negative-integer s 3 5)))
        (* sign 60 (+ (* 60 hours) minutes)))) ; seconds east of Greenwich
     (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 space zone-offset)
  ;; We could verify the day of the week but we don't.
  (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd")
         (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 zone-offset)))
        ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd")
         (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 zone-offset)))

        ;; The next two clauses match dates that have a space instead of
        ;; a leading zero for hours, like " 8:49:37".
        ((string-match? (substring str 0 space) "aaa, dd aaa dddd  d:dd:dd")
         (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 18 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 zone-offset)))
        ((string-match? (substring str 0 space) "aaa, d aaa dddd  d:dd:dd")
         (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 17 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 zone-offset)))

        (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 space zone-offset)
  ;; We could verify the day of the week but we don't.
  (let ((tail (substring str (1+ comma) space)))
    (unless (string-match? tail " dd-aaa-dd dd:dd:dd")
      (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)))
                 zone-offset))))

;; ANSI C's asctime() format
;; Sun Nov  6 08:49:37 1994
;; 012345678901234567890123
;; 0         1         2
(define (parse-asctime-date str)
  (unless (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)))

;; Convert all date values to GMT time zone, as per RFC 2616 appendix C.
(define (normalize-date date)
  (if (zero? (date-zone-offset date))
      date
      (time-utc->date (date->time-utc date) 0)))

(define (parse-date str)
  (let* ((space (string-rindex str #\space))
         (zone-offset (and space (false-if-exception
                                  (parse-zone-offset str (1+ space))))))
    (normalize-date
     (if zone-offset
         (let ((comma (string-index str #\,)))
           (cond ((not comma) (bad-header 'date str))
                 ((= comma 3) (parse-rfc-822-date str space zone-offset))
                 (else (parse-rfc-850-date str comma space zone-offset))))
         (parse-asctime-date str)))))

(define (write-date date port)
  (define (put-digits port n digits)
    (define zero (char->integer #\0))
    (let lp ((tens (expt 10 (1- digits))))
      (when (> tens 0)
        (put-char port
                  (integer->char (+ zero (modulo (truncate/ n tens) 10))))
        (lp (floor/ tens 10)))))
  (let ((date (if (zero? (date-zone-offset date))
                  date
                  (time-tai->date (date->time-tai date) 0))))
    (put-string port
                (case (date-week-day date)
                  ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ")
                  ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ")
                  ((6) "Sat, ") (else (error "bad date" date))))
    (put-digits port (date-day date) 2)
    (put-string port
                (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))))
    (put-digits port (date-year date) 4)
    (put-char port #\space)
    (put-digits port (date-hour date) 2)
    (put-char port #\:)
    (put-digits port (date-minute date) 2)
    (put-char port #\:)
    (put-digits port (date-second date) 2)
    (put-string port " GMT")))

;; Following https://tools.ietf.org/html/rfc7232#section-2.3, an entity
;; tag should really be a qstring.  However there are a number of
;; servers that emit etags as unquoted strings.  Assume that if the
;; value doesn't start with a quote, it's an unquoted strong etag.
(define* (parse-entity-tag val #:optional (start 0) (end (string-length val))
                           #:key sloppy-delimiters)
  (define (parse-proper-etag-at start strong?)
    (cond
     (sloppy-delimiters
      (call-with-values (lambda ()
                          (parse-qstring val start end #:incremental? #t))
        (lambda (tag next)
          (values (cons tag strong?) next))))
     (else
      (values (cons (parse-qstring val start end) strong?) end))))
  (cond
   ((string-prefix? "W/" val 0 2 start end)
    (parse-proper-etag-at (+ start 2) #f))
   ((string-prefix? "\"" val 0 1 start end)
    (parse-proper-etag-at start #t))
   (else
    (let ((delim (or (and sloppy-delimiters
                          (string-index val sloppy-delimiters start end))
                     end)))
      (values (cons (substring val start delim) #t) delim)))))

(define (entity-tag? val)
  (match val
    (((? string?) . _) #t)
    (_ #f)))

(define (put-entity-tag port val)
  (match val
    ((tag . strong?)
     (unless strong? (put-string port "W/"))
     (write-qstring tag port))))

(define* (parse-entity-tag-list val #:optional
                                (start 0) (end (string-length val)))
  (call-with-values (lambda ()
                      (parse-entity-tag val start end #:sloppy-delimiters #\,))
    (lambda (etag next)
      (cons etag
            (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 (put-entity-tag-list port val)
  (put-list port val put-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-set:whitespace start end) end)))
    (when (= 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)))
           (unless (< start end)
             (bad-header-component 'credentials str))
           (cons scheme (substring str start end))))
        (else
         (cons scheme (parse-key-value-list str default-val-parser delim end)))))))

(define (validate-credentials val)
  (match val
    (('basic . (? string?)) #t)
    (((? symbol?) . (? key-value-list?)) #t)
    (_ #f)))

(define (write-credentials val port)
  (match val
    (('basic . cred)
     (put-string port "basic ")
     (put-string port cred))
    ((scheme . params)
     (put-symbol port scheme)
     (put-char port #\space)
     (write-key-value-list params 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)))
                        (unless (or (= i end) (eqv? (string-ref str i) #\,))
                          (bad-header-component 'challenge
                                                (substring str start end)))
                        (lp (1+ i) (cons (if v (cons k v) k) out))))))))))))

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

(define (validate-challenges val)
  (match val
    ((((? symbol?) . (? key-value-list?)) ...) #t)
    (_ #f)))

(define (put-challenge port val)
  (match val
    ((scheme . params)
     (put-symbol port scheme)
     (put-char port #\space)
     (write-key-value-list params port))))

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