module/web/http.scm

   1 ;;; HTTP messages
   2
   3 ;; Copyright (C)  2010 Free Software Foundation, Inc.
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18 ;; 02110-1301 USA
  19
  20 ;;; Code:
  21
  22 (define-module (web http)
  23   #:use-module ((srfi srfi-1) #:select (append-map! map!))
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-19)
  26   #:use-module (ice-9 regex)
  27   #:use-module (ice-9 rdelim)
  28   #:use-module (web uri)
  29   #:export (header-decl?
  30             make-header-decl
  31             header-decl-sym
  32             header-decl-name
  33             header-decl-multiple?
  34             header-decl-parser
  35             header-decl-validator
  36             header-decl-writer
  37             lookup-header-decl
  38             declare-header!
  39
  40             read-header
  41             parse-header
  42             valid-header?
  43             write-header
  44
  45             read-headers
  46             write-headers
  47
  48             parse-http-method
  49             parse-http-version
  50             parse-request-uri
  51
  52             read-request-line
  53             write-request-line
  54             read-response-line
  55             write-response-line))
  56
  57
  58 ;;; TODO
  59 ;;;
  60 ;;; Look at quality lists with more insight.
  61 ;;; Think about `accept' a bit more.
  62 ;;;
  63
  64
  65 (define-record-type <header-decl>
  66   (make-header-decl sym name multiple? parser validator writer)
  67   header-decl?
  68   (sym header-decl-sym)
  69   (name header-decl-name)
  70   (multiple? header-decl-multiple?)
  71   (parser header-decl-parser)
  72   (validator header-decl-validator)
  73   (writer header-decl-writer))
  74
  75 ;; sym -> header
  76 (define *declared-headers* (make-hash-table))
  77 ;; downcased name -> header
  78 (define *declared-headers-by-name* (make-hash-table))
  79
  80 (define* (declare-header! sym name #:key
  81                           multiple?
  82                           parser
  83                           validator
  84                           writer)
  85   (if (and (symbol? sym) (string? name) parser validator writer)
  86       (let ((decl (make-header-decl sym name
  87                                     multiple? parser validator writer)))
  88         (hashq-set! *declared-headers* sym decl)
  89         (hash-set! *declared-headers-by-name* (string-downcase name) decl)
  90         decl)
  91       (error "bad header decl" sym name multiple? parser validator writer)))
  92
  93 (define (read-line* port)
  94   (let* ((pair (%read-line port))
  95          (line (car pair))
  96          (delim (cdr pair)))
  97     (if (and (string? line) (char? delim))
  98         (let ((orig-len (string-length line)))
  99           (let lp ((len orig-len))
 100             (if (and (> len 0)
 101                      (char-whitespace? (string-ref line (1- len))))
 102                 (lp (1- len))
 103                 (if (= len orig-len)
 104                     line
 105                     (substring line 0 len)))))
 106         (bad-header '%read line))))
 107
 108 (define (read-continuation-line port val)
 109   (if (or (eqv? (peek-char port) #\space)
 110           (eqv? (peek-char port) #\tab))
 111       (read-continuation-line port
 112                               (string-append val
 113                                              (begin
 114                                                (read-line* port))))
 115       val))
 116
 117 (define (read-header port)
 118   (let ((line (read-line* port)))
 119     (if (or (string-null? line)
 120             (string=? line "\r"))
 121         (values #f #f)
 122         (let ((delim (or (string-index line #\:)
 123                          (bad-header '%read line))))
 124           (parse-header
 125            (substring line 0 delim)
 126            (read-continuation-line
 127             port
 128             (string-trim-both line char-whitespace? (1+ delim))))))))
 129
 130 (define (lookup-header-decl name)
 131   (if (string? name)
 132       (hash-ref *declared-headers-by-name* (string-downcase name))
 133       (hashq-ref *declared-headers* name)))
 134
 135 (define (parse-header name val)
 136   (let* ((down (string-downcase name))
 137          (decl (hash-ref *declared-headers-by-name* down)))
 138     (if decl
 139         (values (header-decl-sym decl)
 140                 ((header-decl-parser decl) val))
 141         (values down val))))
 142
 143 (define (valid-header? sym val)
 144   (let ((decl (hashq-ref *declared-headers* sym)))
 145     (if (not decl)
 146         (error "Unknown header" sym)
 147         ((header-decl-validator decl) val))))
 148
 149 (define (write-header name val port)
 150   (if (string? name)
 151       ;; assume that it's a header we don't know about...
 152       (begin
 153         (display name port)
 154         (display ": " port)
 155         (display val port)
 156         (display "\r\n" port))
 157       (let ((decl (hashq-ref *declared-headers* name)))
 158         (if (not decl)
 159             (error "Unknown header" name)
 160             (begin
 161               (display (header-decl-name decl) port)
 162               (display ": " port)
 163               ((header-decl-writer decl) val port)
 164               (display "\r\n" port))))))
 165
 166 (define (read-headers port)
 167   (let lp ((headers '()))
 168     (call-with-values (lambda () (read-header port))
 169       (lambda (k v)
 170         (if k
 171             (lp (acons k v headers))
 172             (reverse! headers))))))
 173
 174 ;; Doesn't write the final \r\n, as the user might want to add another
 175 ;; header.
 176 (define (write-headers headers port)
 177   (let lp ((headers headers))
 178     (if (pair? headers)
 179         (begin
 180           (write-header (caar headers) (cdar headers) port)
 181           (lp (cdr headers))))))
 182
 183
 184 \f
 185
 186 ;;;
 187 ;;; Utilities
 188 ;;;
 189
 190 (define (bad-header sym val)
 191   (throw 'bad-header sym val))
 192 (define (bad-header-component sym val)
 193   (throw 'bad-header sym val))
 194
 195 (define (parse-opaque-string str)
 196   str)
 197 (define (validate-opaque-string val)
 198   (string? val))
 199 (define (write-opaque-string val port)
 200   (display val port))
 201
 202 (define not-separator
 203   "[^][()<>@,;:\\\"/?= \t]")
 204 (define media-type-re
 205   (make-regexp (format #f "^(~a+)/(~a+)$" not-separator not-separator)))
 206 (define (parse-media-type str)
 207   (let ((m (regexp-exec media-type-re str)))
 208     (if m
 209         (values (match:substring m 1) (match:substring m 2))
 210         (bad-header-component 'media-type str))))
 211
 212 (define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
 213   (let lp ((i start))
 214     (if (and (< i end) (char-whitespace? (string-ref str i)))
 215         (lp (1+ i))
 216         i)))
 217
 218 (define* (trim-whitespace str #:optional (start 0) (end (string-length str)))
 219   (let lp ((i end))
 220     (if (and (< start i) (char-whitespace? (string-ref str (1- i))))
 221         (lp (1- i))
 222         i)))
 223
 224 (define* (split-and-trim str #:optional (delim #\,)
 225                          (start 0) (end (string-length str)))
 226   (let lp ((i start))
 227     (if (< i end)
 228         (let* ((idx (string-index str delim i end))
 229                (tok (string-trim-both str char-whitespace? i (or idx end))))
 230           (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
 231         '())))
 232
 233 (define (collect-escaped-string from start len escapes)
 234   (let ((to (make-string len)))
 235     (let lp ((start start) (i 0) (escapes escapes))
 236       (if (null? escapes)
 237           (begin
 238             (substring-move! from start (+ start (- len i)) to i)
 239             to)
 240           (let* ((e (car escapes))
 241                  (next-start (+ start (- e i) 2)))
 242             (substring-move! from start (- next-start 2) to i)
 243             (string-set! to e (string-ref from (- next-start 1)))
 244             (lp next-start (1+ e) (cdr escapes)))))))
 245
 246 ;; in incremental mode, returns two values: the string, and the index at
 247 ;; which the string ended
 248 (define* (parse-qstring str #:optional
 249                         (start 0) (end (trim-whitespace str start))
 250                         #:key incremental?)
 251   (if (and (< start end) (eqv? (string-ref str start) #\"))
 252       (let lp ((i (1+ start)) (qi 0) (escapes '()))
 253         (if (< i end)
 254             (case (string-ref str i)
 255               ((#\\)
 256                (lp (+ i 2) (1+ qi) (cons qi escapes)))
 257               ((#\")
 258                (let ((out (collect-escaped-string str (1+ start) qi escapes)))
 259                  (if incremental?
 260                      (values out (1+ i))
 261                      (if (= (1+ i) end)
 262                          out
 263                          (bad-header-component 'qstring str)))))
 264               (else
 265                (lp (1+ i) (1+ qi) escapes)))
 266             (bad-header-component 'qstring str)))
 267       (bad-header-component 'qstring str)))
 268
 269 (define (write-list l port write-item delim)
 270   (if (pair? l)
 271       (let lp ((l l))
 272         (write-item (car l) port)
 273         (if (pair? (cdr l))
 274             (begin
 275               (display delim port)
 276               (lp (cdr l)))))))
 277
 278 (define (write-qstring str port)
 279   (display #\" port)
 280   (if (string-index str #\")
 281       ;; optimize me
 282       (write-list (string-split str #\") port display "\\\"")
 283       (display str port))
 284   (display #\" port))
 285
 286 (define* (parse-quality str #:optional (start 0) (end (string-length str)))
 287   (define (char->decimal c)
 288     (let ((i (- (char->integer c) (char->integer #\0))))
 289       (if (and (<= 0 i) (< i 10))
 290           i
 291           (bad-header-component 'quality str))))
 292   (cond
 293    ((not (< start end))
 294     (bad-header-component 'quality str))
 295    ((eqv? (string-ref str start) #\1)
 296     (if (or (string= str "1" start end)
 297             (string= str "1." start end)
 298             (string= str "1.0" start end)
 299             (string= str "1.00" start end)
 300             (string= str "1.000" start end))
 301         1000
 302         (bad-header-component 'quality str)))
 303    ((eqv? (string-ref str start) #\0)
 304     (if (or (string= str "0" start end)
 305             (string= str "0." start end))
 306         0
 307         (if (< 2 (- end start) 6)
 308             (let lp ((place 1) (i (+ start 4)) (q 0))
 309               (if (= i (1+ start))
 310                   (if (eqv? (string-ref str (1+ start)) #\.)
 311                       q
 312                       (bad-header-component 'quality str))
 313                   (lp (* 10 place) (1- i)
 314                       (if (< i end)
 315                           (+ q (* place (char->decimal (string-ref str i))))
 316                           q))))
 317             (bad-header-component 'quality str))))
 318    (else
 319     (bad-header-component 'quality str))))
 320
 321 (define (valid-quality? q)
 322   (and (non-negative-integer? q) (<= 1000 q)))
 323
 324 (define (write-quality q port)
 325   (define (digit->char d)
 326     (integer->char (+ (char->integer #\0) d)))
 327   (display (digit->char (modulo (quotient q 1000) 10)) port)
 328   (display #\. port)
 329   (display (digit->char (modulo (quotient q 100) 10)) port)
 330   (display (digit->char (modulo (quotient q 10) 10)) port)
 331   (display (digit->char (modulo q 10)) port))
 332
 333 (define (list-of? val pred)
 334   (or (null? val)
 335       (and (pair? val)
 336            (pred (car val))
 337            (list-of? (cdr val) pred))))
 338
 339 (define* (parse-quality-list str)
 340   (map (lambda (part)
 341          (cond
 342           ((string-rindex part #\;)
 343            => (lambda (idx)
 344                 (let ((qpart (string-trim-both part char-whitespace? (1+ idx))))
 345                   (if (string-prefix? "q=" qpart)
 346                       (cons (parse-quality qpart 2)
 347                             (string-trim-both part char-whitespace? 0 idx))
 348                       (bad-header-component 'quality qpart)))))
 349           (else
 350            (cons 1000 (string-trim-both part char-whitespace?)))))
 351        (string-split str #\,)))
 352
 353 (define (validate-quality-list l)
 354   (list-of? l
 355             (lambda (elt)
 356               (and (pair? elt)
 357                    (valid-quality? (car elt))
 358                    (string? (cdr elt))))))
 359
 360 (define (write-quality-list l port)
 361   (write-list l port
 362               (lambda (x port)
 363                 (let ((q (car x))
 364                       (str (cdr x)))
 365                   (display str port)
 366                   (if (< q 1000)
 367                       (begin
 368                         (display ";q=" port)
 369                         (write-quality q port)))))
 370               ","))
 371
 372 (define* (parse-non-negative-integer val #:optional (start 0)
 373                                      (end (string-length val)))
 374   (define (char->decimal c)
 375     (let ((i (- (char->integer c) (char->integer #\0))))
 376       (if (and (<= 0 i) (< i 10))
 377           i
 378           (bad-header-component 'non-negative-integer val))))
 379   (if (not (< start end))
 380       (bad-header-component 'non-negative-integer val)
 381       (let lp ((i start) (out 0))
 382         (if (< i end)
 383             (lp (1+ i)
 384                 (+ (* out 10) (char->decimal (string-ref val i))))
 385             out))))
 386
 387 (define (non-negative-integer? code)
 388   (and (number? code) (>= code 0) (exact? code) (integer? code)))
 389
 390 (define (default-kons k val)
 391   (if val
 392       (cons k val)
 393       k))
 394
 395 (define (default-kv-validator k val)
 396   #t)
 397
 398 (define (default-val-writer k val port)
 399   (if (or (string-index val #\;)
 400           (string-index val #\,)
 401           (string-index val #\"))
 402       (write-qstring val port)
 403       (display val port)))
 404
 405 (define* (parse-key-value-list str #:optional (kproc identity)
 406                                (kons default-kons)
 407                                (start 0) (end (string-length str)))
 408   (let lp ((i start) (out '()))
 409     (if (not (< i end))
 410         (reverse! out)
 411         (let* ((i (skip-whitespace str i end))
 412                (eq (string-index str #\= i end))
 413                (comma (string-index str #\, i end))
 414                (delim (min (or eq end) (or comma end)))
 415                (k (kproc (substring str i (trim-whitespace str i delim)))))
 416           (call-with-values
 417               (lambda ()
 418                 (if (and eq (or (not comma) (< eq comma)))
 419                     (let ((i (skip-whitespace str (1+ eq) end)))
 420                       (if (and (< i end) (eqv? (string-ref str i) #\"))
 421                           (parse-qstring str i end #:incremental? #t)
 422                           (values (substring str i
 423                                              (trim-whitespace str i
 424                                                               (or comma end)))
 425                                   (or comma end))))
 426                     (values #f delim)))
 427             (lambda (v-str next-i)
 428               (let ((i (skip-whitespace str next-i end)))
 429                 (if (or (= i end) (eqv? (string-ref str i) #\,))
 430                     (lp (1+ i) (cons (kons k v-str) out))
 431                     (bad-header-component 'key-value-list
 432                                           (substring str start end))))))))))
 433
 434 (define* (key-value-list? list #:optional
 435                           (valid? default-kv-validator))
 436   (list-of? list
 437             (lambda (elt)
 438               (cond
 439                ((pair? elt)
 440                 (let ((k (car elt))
 441                       (v (cdr elt)))
 442                   (and (or (string? k) (symbol? k))
 443                        (valid? k v))))
 444                ((or (string? elt) (symbol? elt))
 445                 (valid? elt #f))
 446                (else #f)))))
 447
 448 (define* (write-key-value-list list port #:optional
 449                                (val-writer default-val-writer) (delim ", "))
 450   (write-list
 451    list port
 452    (lambda (x port)
 453      (let ((k (if (pair? x) (car x) x))
 454            (v (if (pair? x) (cdr x) #f)))
 455        (display k port)
 456        (if v
 457            (begin
 458              (display #\= port)
 459              (val-writer k v port)))))
 460    delim))
 461
 462 ;; param-component = token [ "=" (token | quoted-string) ] \
 463 ;;    *(";" token [ "=" (token | quoted-string) ])
 464 ;;
 465 (define* (parse-param-component str #:optional (kproc identity)
 466                                 (kons default-kons)
 467                                 (start 0) (end (string-length str)))
 468   (let lp ((i start) (out '()))
 469     (if (not (< i end))
 470         (values (reverse! out) end)
 471         (let ((delim (string-index str
 472                                    (lambda (c) (memq c '(#\, #\; #\=)))
 473                                    i)))
 474           (let ((k (kproc
 475                     (substring str i (trim-whitespace str i (or delim end)))))
 476                 (delimc (and delim (string-ref str delim))))
 477             (case delimc
 478               ((#\=)
 479                (call-with-values
 480                    (lambda ()
 481                      (let ((i (skip-whitespace str (1+ delim) end)))
 482                        (if (and (< i end) (eqv? (string-ref str i) #\"))
 483                            (parse-qstring str i end #:incremental? #t)
 484                            (let ((delim
 485                                   (or (string-index
 486                                        str
 487                                        (lambda (c)
 488                                          (or (eqv? c #\;)
 489                                              (eqv? c #\,)
 490                                              (char-whitespace? c)))
 491                                        i end)
 492                                       end)))
 493                              (values (substring str i delim)
 494                                      delim)))))
 495                  (lambda (v-str next-i)
 496                    (let ((x (kons k v-str))
 497                          (i (skip-whitespace str next-i end)))
 498                      (case (and (< i end) (string-ref str i))
 499                        ((#f)
 500                         (values (reverse! (cons x out)) end))
 501                        ((#\;)
 502                         (lp (skip-whitespace str (1+ i) end)
 503                             (cons x out)))
 504                        (else            ; including #\,
 505                         (values (reverse! (cons x out)) i)))))))
 506               ((#\;)
 507                (lp (skip-whitespace str (1+ delim) end)
 508                    (cons (kons k #f) out)))
 509
 510               (else ;; either the end of the string or a #\,
 511                (values (reverse! (cons (kons k #f) out))
 512                        (or delim end)))))))))
 513
 514 (define* (parse-param-list str #:optional
 515                            (kproc identity) (kons default-kons)
 516                            (start 0) (end (string-length str)))
 517   (let lp ((i start) (out '()))
 518     (call-with-values
 519         (lambda () (parse-param-component str kproc kons i end))
 520       (lambda (item i)
 521         (if (< i end)
 522             (if (eqv? (string-ref str i) #\,)
 523                 (lp (skip-whitespace str (1+ i) end)
 524                     (cons item out))
 525                 (bad-header-component 'param-list str))
 526             (reverse! (cons item out)))))))
 527
 528 (define* (validate-param-list list #:optional
 529                               (valid? default-kv-validator))
 530   (list-of? list
 531             (lambda (elt)
 532               (key-value-list? list valid?))))
 533
 534 (define* (write-param-list list port #:optional
 535                            (val-writer default-val-writer))
 536   (write-list
 537    list port
 538    (lambda (item port)
 539      (write-key-value-list item port val-writer ";"))
 540    ","))
 541
 542 (define (list-of-strings? val)
 543   (list-of? val string?))
 544
 545 (define (write-list-of-strings val port)
 546   (write-list val port display ", "))
 547
 548 (define (parse-date str)
 549   ;; Unfortunately, there is no way to make string->date parse out the
 550   ;; "GMT" bit, so we play string games to append a format it will
 551   ;; understand (the +0000 bit).
 552   (string->date
 553    (if (string-suffix? " GMT" str)
 554        (string-append (substring str 0 (- (string-length str) 4))
 555                       " +0000")
 556        (bad-header-component 'date str))
 557    "~a, ~d ~b ~Y ~H:~M:~S ~z"))
 558
 559 (define (write-date date port)
 560   (display (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT") port))
 561
 562 (define (write-uri uri port)
 563   (display (unparse-uri uri) port))
 564
 565 (define (parse-entity-tag val)
 566   (if (string-prefix? "W/" val)
 567       (cons (parse-qstring val 2) #f)
 568       (cons (parse-qstring val) #t)))
 569
 570 (define (entity-tag? val)
 571   (and (pair? val)
 572        (string? (car val))))
 573
 574 (define (write-entity-tag val port)
 575   (if (cdr val)
 576       (display "W/" port))
 577   (write-qstring (car val) port))
 578
 579 (define* (parse-entity-tag-list val #:optional
 580                                 (start 0) (end (string-length val)))
 581   (let ((strong? (not (string-prefix? "W/" val 0 2 start end))))
 582     (call-with-values (lambda ()
 583                         (parse-qstring val (if strong? start (+ start 2))
 584                                        end #:incremental? #t))
 585       (lambda (tag next)
 586         (acons tag strong?
 587                (let ((next (skip-whitespace val next end)))
 588                   (if (< next end)
 589                       (if (eqv? (string-ref val next) #\,)
 590                           (parse-entity-tag-list
 591                            val
 592                            (skip-whitespace val (1+ next) end)
 593                            end)
 594                           (bad-header-component 'entity-tag-list val))
 595                       '())))))))
 596
 597 (define (entity-tag-list? val)
 598   (list-of? val entity-tag?))
 599
 600 (define (write-entity-tag-list val port)
 601   (write-list val port write-entity-tag  ", "))
 602
 603
 604 \f
 605
 606 ;;;
 607 ;;; Request-Line and Response-Line
 608 ;;;
 609
 610 ;; Hmm.
 611 (define (bad-request message . args)
 612   (throw 'bad-request message args))
 613 (define (bad-response message . args)
 614   (throw 'bad-response message args))
 615
 616 (define *known-versions* '())
 617
 618 (define* (parse-http-version str #:optional (start 0) (end (string-length str)))
 619   (or (let lp ((known *known-versions*))
 620         (and (pair? known)
 621              (if (string= str (caar known) start end)
 622                  (cdar known)
 623                  (lp (cdr known)))))
 624       (let ((dot-idx (string-index str #\. start end)))
 625         (if (and (string-prefix? "HTTP/" str 0 5 start end)
 626                  dot-idx
 627                  (= dot-idx (string-rindex str #\. start end)))
 628             (cons (parse-non-negative-integer str (+ start 5) dot-idx)
 629                   (parse-non-negative-integer str (1+ dot-idx) end))
 630             (bad-header-component 'http-version (substring str start end))))))
 631
 632 (define (write-http-version val port)
 633   (display "HTTP/" port)
 634   (display (car val) port)
 635   (display #\. port)
 636   (display (cdr val) port))
 637
 638 (for-each
 639  (lambda (v)
 640    (set! *known-versions*
 641          (acons v (parse-http-version v 0 (string-length v))
 642                 *known-versions*)))
 643  '("HTTP/1.0" "HTTP/1.1"))
 644
 645
 646 ;; Request-URI = "*" | absoluteURI | abs_path | authority
 647 ;;
 648 ;; The `authority' form is only permissible for the CONNECT method, so
 649 ;; because we don't expect people to implement CONNECT, we save
 650 ;; ourselves the trouble of that case, and disallow the CONNECT method.
 651 ;;
 652 (define* (parse-http-method str #:optional (start 0) (end (string-length str)))
 653   (cond
 654    ((string= str "GET" start end) 'GET)
 655    ((string= str "HEAD" start end) 'HEAD)
 656    ((string= str "POST" start end) 'POST)
 657    ((string= str "PUT" start end) 'PUT)
 658    ((string= str "DELETE" start end) 'DELETE)
 659    ((string= str "OPTIONS" start end) 'OPTIONS)
 660    ((string= str "TRACE" start end) 'TRACE)
 661    (else (bad-request "Invalid method: ~a" (substring str start end)))))
 662
 663 (define* (parse-request-uri str #:optional (start 0) (end (string-length str)))
 664   (cond
 665    ((= start end)
 666     (bad-request "Missing Request-URI"))
 667    ((string= str "*" start end)
 668     #f)
 669    ((eq? (string-ref str start) #\/)
 670     (let* ((q (string-index str #\? start end))
 671            (f (string-index str #\# start end))
 672            (q (and q (or (not f) (< q f)) q)))
 673       (build-uri 'http
 674                  #:path (substring str start (or q f end))
 675                  #:query (and q (substring str (1+ q) (or f end)))
 676                  #:fragment (and f (substring str (1+ f) end)))))
 677    (else
 678     (or (parse-uri (substring str start end))
 679         (bad-request "Invalid URI: ~a" (substring str start end))))))
 680
 681 (define (read-request-line port)
 682   (let* ((line (read-line* port))
 683          (d0 (string-index line char-whitespace?)) ; "delimiter zero"
 684          (d1 (string-rindex line char-whitespace?)))
 685     (if (and d0 d1 (< d0 d1))
 686         (values (parse-http-method line 0 d0)
 687                 (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
 688                 (parse-http-version line (1+ d1) (string-length line)))
 689         (bad-request "Bad Request-Line: ~s" line))))
 690
 691 (define (write-uri uri port)
 692   (if (uri-host uri)
 693       (begin
 694         (display (uri-scheme uri) port)
 695         (display "://" port)
 696         (if (uri-userinfo uri)
 697             (begin
 698               (display (uri-userinfo uri) port)
 699               (display #\@ port)))
 700         (display (uri-host uri) port)
 701         (let ((p (uri-port uri)))
 702           (if (and p (not (eqv? p 80)))
 703               (begin
 704                 (display #\: port)
 705                 (display p port))))))
 706   (let* ((path (uri-path uri))
 707          (len (string-length path)))
 708     (cond
 709      ((and (> len 0) (not (eqv? (string-ref path 0) #\/)))
 710       (bad-request "Non-absolute URI path: ~s" path))
 711      ((and (zero? len) (not (uri-host uri)))
 712       (bad-request "Empty path and no host for URI: ~s" uri))
 713      (else
 714       (display path port))))
 715   (if (uri-query uri)
 716       (begin
 717         (display #\? port)
 718         (display (uri-query uri) port))))
 719
 720 (define (write-request-line method uri version port)
 721   (display method port)
 722   (display #\space port)
 723   (write-uri uri port)
 724   (display #\space port)
 725   (write-http-version version port)
 726   (display "\r\n" port))
 727
 728 (define (read-response-line port)
 729   (let* ((line (read-line* port))
 730          (d0 (string-index line char-whitespace?)) ; "delimiter zero"
 731          (d1 (and d0 (string-index line char-whitespace?
 732                                    (skip-whitespace line d0)))))
 733     (if (and d0 d1)
 734         (values (parse-http-version line 0 d0)
 735                 (parse-non-negative-integer line (skip-whitespace line d0 d1)
 736                                             d1)
 737                 (string-trim-both line char-whitespace? d1))
 738         (bad-response "Bad Response-Line: ~s" line))))
 739
 740 (define (write-response-line version code reason-phrase port)
 741   (write-http-version version port)
 742   (display #\space port)
 743   (display code port)
 744   (display #\space port)
 745   (display reason-phrase port)
 746   (display "\r\n" port))
 747
 748
 749 \f
 750
 751 ;;;
 752 ;;; Syntax for declaring headers
 753 ;;;
 754
 755 ;; emacs: (put 'declare-header 'scheme-indent-function 1)
 756 (define-syntax declare-header
 757   (syntax-rules ()
 758     ((_ sym name parser validator writer arg ...)
 759      (declare-header!
 760       'sym name
 761       #:parser parser #:validator validator #:writer writer
 762       arg ...))))
 763
 764 ;; emacs: (put 'declare-opaque-header 'scheme-indent-function 1)
 765 (define-syntax declare-opaque-header
 766   (syntax-rules ()
 767     ((_ sym name)
 768      (declare-header sym
 769        name
 770        parse-opaque-string validate-opaque-string write-opaque-string))))
 771
 772 ;; emacs: (put 'declare-date-header 'scheme-indent-function 1)
 773 (define-syntax declare-date-header
 774   (syntax-rules ()
 775     ((_ sym name)
 776      (declare-header sym
 777        name
 778        parse-date date? write-date))))
 779
 780 ;; emacs: (put 'declare-string-list-header 'scheme-indent-function 1)
 781 (define-syntax declare-string-list-header
 782   (syntax-rules ()
 783     ((_ sym name)
 784      (declare-header sym
 785        name
 786        split-and-trim list-of-strings? write-list-of-strings))))
 787
 788 ;; emacs: (put 'declare-integer-header 'scheme-indent-function 1)
 789 (define-syntax declare-integer-header
 790   (syntax-rules ()
 791     ((_ sym name)
 792      (declare-header sym
 793        name
 794        parse-non-negative-integer non-negative-integer? display))))
 795
 796 ;; emacs: (put 'declare-uri-header 'scheme-indent-function 1)
 797 (define-syntax declare-uri-header
 798   (syntax-rules ()
 799     ((_ sym name)
 800      (declare-header sym
 801        name
 802        (lambda (str) (or (parse-uri str) (bad-header-component 'uri str)))
 803        uri?
 804        write-uri))))
 805
 806 ;; emacs: (put 'declare-quality-list-header 'scheme-indent-function 1)
 807 (define-syntax declare-quality-list-header
 808   (syntax-rules ()
 809     ((_ sym name)
 810      (declare-header sym
 811        name
 812        parse-quality-list validate-quality-list write-quality-list))))
 813
 814 ;; emacs: (put 'declare-param-list-header 'scheme-indent-function 1)
 815 (define-syntax declare-param-list-header
 816   (syntax-rules ()
 817     ((_ sym name)
 818      (declare-param-list-header sym name identity default-kons
 819                                 default-kv-validator default-val-writer))
 820     ((_ sym name kproc)
 821      (declare-param-list-header sym name kproc default-kons
 822                                 default-kv-validator default-val-writer))
 823     ((_ sym name kproc kons val-validator val-writer)
 824      (declare-header sym
 825        name
 826        (lambda (str) (parse-param-list str kproc kons))
 827        (lambda (val) (validate-param-list val val-validator))
 828        (lambda (val port) (write-param-list val port val-writer))))))
 829
 830 ;; emacs: (put 'declare-key-value-list-header 'scheme-indent-function 1)
 831 (define-syntax declare-key-value-list-header
 832   (syntax-rules ()
 833     ((_ sym name)
 834      (declare-key-value-list-header sym name identity default-kons
 835                                     default-kv-validator default-val-writer))
 836     ((_ sym name kproc)
 837      (declare-key-value-list-header sym name kproc default-kons
 838                                     default-kv-validator default-val-writer))
 839     ((_ sym name kproc kons val-validator val-writer)
 840      (declare-header sym
 841        name
 842        (lambda (str) (parse-key-value-list str kproc kons))
 843        (lambda (val) (key-value-list? val val-validator))
 844        (lambda (val port) (write-key-value-list val port val-writer))))))
 845
 846 ;; emacs: (put 'declare-entity-tag-list-header 'scheme-indent-function 1)
 847 (define-syntax declare-entity-tag-list-header
 848   (syntax-rules ()
 849     ((_ sym name)
 850      (declare-header sym
 851        name
 852        (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str)))
 853        (lambda (val) (or (eq? val '*) (entity-tag-list? val)))
 854        (lambda (val port)
 855          (if (eq? val '*)
 856              (display "*" port)
 857              (write-entity-tag-list val port)))))))
 858
 859
 860 \f
 861
 862 ;;;
 863 ;;; General headers
 864 ;;;
 865
 866 ;; Cache-Control   = 1#(cache-directive)
 867 ;; cache-directive = cache-request-directive | cache-response-directive
 868 ;; cache-request-directive =
 869 ;;        "no-cache"                          ; Section 14.9.1
 870 ;;      | "no-store"                          ; Section 14.9.2
 871 ;;      | "max-age" "=" delta-seconds         ; Section 14.9.3, 14.9.4
 872 ;;      | "max-stale" [ "=" delta-seconds ]   ; Section 14.9.3
 873 ;;      | "min-fresh" "=" delta-seconds       ; Section 14.9.3
 874 ;;      | "no-transform"                      ; Section 14.9.5
 875 ;;      | "only-if-cached"                    ; Section 14.9.4
 876 ;;      | cache-extension                     ; Section 14.9.6
 877 ;;  cache-response-directive =
 878 ;;        "public"                               ; Section 14.9.1
 879 ;;      | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1
 880 ;;      | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1
 881 ;;      | "no-store"                             ; Section 14.9.2
 882 ;;      | "no-transform"                         ; Section 14.9.5
 883 ;;      | "must-revalidate"                      ; Section 14.9.4
 884 ;;      | "proxy-revalidate"                     ; Section 14.9.4
 885 ;;      | "max-age" "=" delta-seconds            ; Section 14.9.3
 886 ;;      | "s-maxage" "=" delta-seconds           ; Section 14.9.3
 887 ;;      | cache-extension                        ; Section 14.9.6
 888 ;; cache-extension = token [ "=" ( token | quoted-string ) ]
 889 ;;
 890 (declare-key-value-list-header cache-control
 891   "Cache-Control"
 892   (let ((known-directives (make-hash-table)))
 893     (for-each (lambda (s)
 894                 (hash-set! known-directives s (string->symbol s)))
 895               '("no-cache" "no-store" "max-age" "max-stale" "min-fresh"
 896                 "no-transform" "only-if-cached" "public" "private"
 897                 "must-revalidate" "proxy-revalidate" "s-maxage"))
 898     (lambda (k-str)
 899       (hash-ref known-directives k-str k-str)))
 900   (lambda (k v-str)
 901     (case k
 902       ((max-age max-stale min-fresh s-maxage)
 903        (cons k (parse-non-negative-integer v-str)))
 904       ((private no-cache)
 905        (cons k (if v-str (split-and-trim v-str) #t)))
 906       (else (if v-str (cons k v-str) k))))
 907   default-kv-validator
 908   (lambda (k v port)
 909     (cond
 910      ((string? v) (display v port))
 911      ((pair? v)
 912       (write-qstring (string-join v ", ") port))
 913      ((integer? v)
 914       (display v port))
 915      (else
 916       (bad-header-component 'cache-control v)))))
 917
 918 ;; Connection = "Connection" ":" 1#(connection-token)
 919 ;; connection-token  = token
 920 ;; e.g.
 921 ;;     Connection: close, foo-header
 922 ;;
 923 (declare-string-list-header connection
 924   "Connection")
 925
 926 ;; Date  = "Date" ":" HTTP-date
 927 ;; e.g.
 928 ;;     Date: Tue, 15 Nov 1994 08:12:31 GMT
 929 ;;
 930 (declare-date-header date
 931   "Date")
 932
 933 ;; Pragma            = "Pragma" ":" 1#pragma-directive
 934 ;; pragma-directive  = "no-cache" | extension-pragma
 935 ;; extension-pragma  = token [ "=" ( token | quoted-string ) ]
 936 ;;
 937 (declare-key-value-list-header pragma
 938   "Pragma"
 939   (lambda (k) (if (equal? k "no-cache") 'no-cache k)))
 940
 941 ;; Trailer  = "Trailer" ":" 1#field-name
 942 ;;
 943 (declare-string-list-header trailer
 944   "Trailer")
 945
 946 ;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding
 947 ;;
 948 (declare-param-list-header transfer-encoding
 949   "Transfer-Encoding"
 950   (lambda (k)
 951     (if (equal? k "chunked") 'chunked k)))
 952
 953 ;; Upgrade = "Upgrade" ":" 1#product
 954 ;;
 955 (declare-string-list-header upgrade
 956   "Upgrade")
 957
 958 ;; Via =  "Via" ":" 1#( received-protocol received-by [ comment ] )
 959 ;; received-protocol = [ protocol-name "/" ] protocol-version
 960 ;; protocol-name     = token
 961 ;; protocol-version  = token
 962 ;; received-by       = ( host [ ":" port ] ) | pseudonym
 963 ;; pseudonym         = token
 964 ;;
 965 (declare-header via
 966   "Via"
 967   split-and-trim
 968   list-of-strings?
 969   write-list-of-strings
 970   #:multiple? #t)
 971
 972 ;; Warning    = "Warning" ":" 1#warning-value
 973 ;;
 974 ;; warning-value = warn-code SP warn-agent SP warn-text
 975 ;;                                       [SP warn-date]
 976 ;;
 977 ;; warn-code  = 3DIGIT
 978 ;; warn-agent = ( host [ ":" port ] ) | pseudonym
 979 ;;                 ; the name or pseudonym of the server adding
 980 ;;                 ; the Warning header, for use in debugging
 981 ;; warn-text  = quoted-string
 982 ;; warn-date  = <"> HTTP-date <">
 983 (declare-header warning
 984   "Warning"
 985   (lambda (str)
 986     (let ((len (string-length str)))
 987       (let lp ((i (skip-whitespace str 0)))
 988         (let* ((idx1 (string-index str #\space i))
 989                (idx2 (string-index str #\space (1+ idx1))))
 990           (if (and idx1 idx2)
 991               (let ((code (parse-non-negative-integer str i idx1))
 992                     (agent (substring str (1+ idx1) idx2)))
 993                 (call-with-values
 994                     (lambda () (parse-qstring str (1+ idx2) #:incremental? #t))
 995                   (lambda (text i)
 996                     (call-with-values
 997                         (lambda ()
 998                           (let ((c (and (< i len) (string-ref str i))))
 999                             (case c
1000                               ((#\space)
1001                                ;; we have a date.
1002                                (call-with-values
1003                                    (lambda () (parse-qstring str (1+ i)
1004                                                              #:incremental? #t))
1005                                  (lambda (date i)
1006                                    (values text (parse-date date) i))))
1007                               (else
1008                                (values text #f i)))))
1009                       (lambda (text date i)
1010                         (let ((w (list code agent text date))
1011                               (c (and (< i len) (string-ref str i))))
1012                           (case c
1013                             ((#f) (list w))
1014                             ((#\,) (cons w (lp (skip-whitespace str (1+ i)))))
1015                             (else (bad-header 'warning str))))))))))))))
1016   (lambda (val)
1017     (list-of? val
1018               (lambda (elt)
1019                 (and (list? elt)
1020                      (= (length elt) 4)
1021                      (apply (lambda (code host text date)
1022                               (and (non-negative-integer? code) (< code 1000)
1023                                    (string? host)
1024                                    (string? text)
1025                                    (or (not date) (date? date))))
1026                             elt)))))
1027   (lambda (val port)
1028     (write-list
1029      val port
1030      (lambda (w port)
1031        (apply
1032         (lambda (code host text date)
1033           (display code port)
1034           (display #\space port)
1035           (display host port)
1036           (display #\space port)
1037           (write-qstring text port)
1038           (if date
1039               (begin
1040                 (display #\space port)
1041                 (write-date date port))))
1042         w))
1043      ", "))
1044   #:multiple? #t)
1045
1046
1047 \f
1048
1049 ;;;
1050 ;;; Entity headers
1051 ;;;
1052
1053 ;; Allow = #Method
1054 ;;
1055 (declare-string-list-header allow
1056   "Allow")
1057
1058 ;; Content-Encoding = 1#content-coding
1059 ;;
1060 (declare-string-list-header content-encoding
1061   "Content-Encoding")
1062
1063 ;; Content-Language = 1#language-tag
1064 ;;
1065 (declare-string-list-header content-language
1066   "Content-Language")
1067
1068 ;; Content-Length = 1*DIGIT
1069 ;;
1070 (declare-integer-header content-length
1071   "Content-Length")
1072
1073 ;; Content-Location = ( absoluteURI | relativeURI )
1074 ;;
1075 (declare-uri-header content-location
1076   "Content-Location")
1077
1078 ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
1079 ;;
1080 (declare-opaque-header content-md5
1081   "Content-MD5")
1082
1083 ;; Content-Range = content-range-spec
1084 ;; content-range-spec      = byte-content-range-spec
1085 ;; byte-content-range-spec = bytes-unit SP
1086 ;;                           byte-range-resp-spec "/"
1087 ;;                           ( instance-length | "*" )
1088 ;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos)
1089 ;;                                | "*"
1090 ;; instance-length           = 1*DIGIT
1091 ;;
1092 (declare-header content-range
1093   "Content-Range"
1094   (lambda (str)
1095     (let ((dash (string-index str #\-))
1096           (slash (string-index str #\/)))
1097       (if (and (string-prefix? "bytes " str) slash)
1098           (list 'bytes
1099                 (cond
1100                  (dash
1101                   (cons
1102                    (parse-non-negative-integer str 6 dash)
1103                    (parse-non-negative-integer str (1+ dash) slash)))
1104                  ((string= str "*" 6 slash)
1105                   '*)
1106                  (else
1107                   (bad-header 'content-range str)))
1108                 (if (string= str "*" (1+ slash))
1109                     '*
1110                     (parse-non-negative-integer str (1+ slash))))
1111           (bad-header 'content-range str))))
1112   (lambda (val)
1113     (and (list? val) (= (length val) 3)
1114          (symbol? (car val))
1115          (let ((x (cadr val)))
1116            (or (eq? x '*)
1117                (and (pair? x)
1118                     (non-negative-integer? (car x))
1119                     (non-negative-integer? (cdr x)))))
1120          (let ((x (caddr val)))
1121            (or (eq? x '*)
1122                (non-negative-integer? x)))))
1123   (lambda (val port)
1124     (display (car val) port)
1125     (display #\space port)
1126     (if (eq? (cadr val) '*)
1127         (display #\* port)
1128         (begin
1129           (display (caadr val) port)
1130           (display #\- port)
1131           (display (caadr val) port)))
1132     (if (eq? (caddr val) '*)
1133         (display #\* port)
1134         (display (caddr val) port))))
1135
1136 ;; Content-Type = media-type
1137 ;;
1138 (declare-header content-type
1139   "Content-Type"
1140   (lambda (str)
1141     (let ((parts (string-split str #\;)))
1142       (call-with-values (lambda () (parse-media-type (car parts)))
1143         (lambda (type subtype)
1144           (cons* type subtype
1145                  (map (lambda (x)
1146                         (let ((eq (string-index x #\=)))
1147                           (if (and eq (= eq (string-rindex x #\=)))
1148                               (cons (string-trim x 0 eq)
1149                                     (string-trim-right x (1+ eq)))
1150                               (bad-header 'content-type str))))
1151                       (cdr parts)))))))
1152   (lambda (val)
1153     (and (list-of? val string?)
1154          (let ((len (length val)))
1155            (and (>= len 2)
1156                 (even? len)))))
1157   (lambda (val port)
1158     (display (car val) port)
1159     (display #\/ port)
1160     (display (cadr val) port)
1161     (write-list
1162      (cddr val) port
1163      (lambda (pair port)
1164        (display (car pair) port)
1165        (display #\= port)
1166        (display (cdr pair) port))
1167      ";")))
1168
1169 ;; Expires = HTTP-date
1170 ;;
1171 (declare-date-header expires
1172   "Expires")
1173
1174 ;; Last-Modified = HTTP-date
1175 ;;
1176 (declare-date-header last-modified
1177   "Last-Modified")
1178
1179
1180 \f
1181
1182 ;;;
1183 ;;; Request headers
1184 ;;;
1185
1186 ;; Accept = #( media-range [ accept-params ] )
1187 ;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) )
1188 ;;               *( ";" parameter )
1189 ;; accept-params = ";" "q" "=" qvalue *( accept-extension )
1190 ;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
1191 ;;
1192 (declare-param-list-header accept
1193   "Accept"
1194   ;; -> ("type/subtype" (str-prop . str-val) ...) ...)
1195   ;;
1196   ;; with the exception of prop = "q", in which case the prop will be
1197   ;; the symbol 'q, and the val will be a valid quality value
1198   ;;
1199   (lambda (k) (if (string=? k "q") 'q k))
1200   (lambda (k v)
1201     (if (eq? k 'q)
1202         (cons k (parse-quality v))
1203         (default-kons k v)))
1204   (lambda (k v)
1205     (if (eq? k 'q)
1206         (valid-quality? v)
1207         (default-kv-validator k v)))
1208   (lambda (k v port)
1209     (if (eq? k 'q)
1210         (write-quality v port)
1211         (default-val-writer k v port))))
1212
1213 ;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] )
1214 ;;
1215 (declare-quality-list-header accept-charset
1216   "Accept-Charset")
1217
1218 ;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] )
1219 ;; codings = ( content-coding | "*" )
1220 ;;
1221 (declare-quality-list-header accept-encoding
1222   "Accept-Encoding")
1223
1224 ;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] )
1225 ;; language-range  = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )
1226 ;;
1227 (declare-quality-list-header accept-language
1228   "Accept-Language")
1229
1230 ;; Authorization = credentials
1231 ;;
1232 ;; Authorization is basically opaque to this HTTP stack, we just pass
1233 ;; the string value through.
1234 ;;
1235 (declare-opaque-header authorization
1236   "Authorization")
1237
1238 ;; Expect = 1#expectation
1239 ;; expectation = "100-continue" | expectation-extension
1240 ;; expectation-extension = token [ "=" ( token | quoted-string )
1241 ;;                         *expect-params ]
1242 ;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
1243 ;;
1244 (declare-param-list-header expect
1245   "Expect"
1246   (lambda (k)
1247     (if (equal? k "100-continue")
1248         '100-continue
1249         k)))
1250
1251 ;; From = mailbox
1252 ;;
1253 ;; Should be an email address; we just pass on the string as-is.
1254 ;;
1255 (declare-opaque-header from
1256   "From")
1257
1258 ;; Host = host [ ":" port ]
1259 ;;
1260 (declare-header host
1261   "Host"
1262   (lambda (str)
1263     (let ((colon (string-index str #\:)))
1264       (if colon
1265           (cons (substring str 0 colon)
1266                 (parse-non-negative-integer str (1+ colon)))
1267           (cons str #f))))
1268   (lambda (val)
1269     (and (pair? val)
1270          (string? (car val))
1271          (or (not (cdr val))
1272              (non-negative-integer? (cdr val)))))
1273   (lambda (val port)
1274     (display (car val) port)
1275     (if (cdr val)
1276         (begin
1277           (display #\: port)
1278           (display (cdr val) port)))))
1279
1280 ;; If-Match = ( "*" | 1#entity-tag )
1281 ;;
1282 (declare-entity-tag-list-header if-match
1283   "If-Match")
1284
1285 ;; If-Modified-Since = HTTP-date
1286 ;;
1287 (declare-date-header if-modified-since
1288   "If-Modified-Since")
1289
1290 ;; If-None-Match = ( "*" | 1#entity-tag )
1291 ;;
1292 (declare-entity-tag-list-header if-none-match
1293   "If-None-Match")
1294
1295 ;; If-Range = ( entity-tag | HTTP-date )
1296 ;;
1297 (declare-header if-range
1298   "If-Range"
1299   (lambda (str)
1300     (if (or (string-prefix? "\"" str)
1301             (string-prefix? "W/" str))
1302         (parse-entity-tag str)
1303         (parse-date str)))
1304   (lambda (val)
1305     (or (date? val) (entity-tag? val)))
1306   (lambda (val port)
1307     (if (date? val)
1308         (write-date val port)
1309         (write-entity-tag val port))))
1310
1311 ;; If-Unmodified-Since = HTTP-date
1312 ;;
1313 (declare-date-header if-unmodified-since
1314   "If-Unmodified-Since")
1315
1316 ;; Max-Forwards = 1*DIGIT
1317 ;;
1318 (declare-integer-header max-forwards
1319   "Max-Forwards")
1320
1321 ;; Proxy-Authorization = credentials
1322 ;;
1323 (declare-opaque-header proxy-authorization
1324   "Proxy-Authorization")
1325
1326 ;; Range = "Range" ":" ranges-specifier
1327 ;; ranges-specifier = byte-ranges-specifier
1328 ;; byte-ranges-specifier = bytes-unit "=" byte-range-set
1329 ;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec )
1330 ;; byte-range-spec = first-byte-pos "-" [last-byte-pos]
1331 ;; first-byte-pos = 1*DIGIT
1332 ;; last-byte-pos = 1*DIGIT
1333 ;; suffix-byte-range-spec = "-" suffix-length
1334 ;; suffix-length = 1*DIGIT
1335 ;;
1336 (declare-header range
1337   "Range"
1338   (lambda (str)
1339     (if (string-prefix? "bytes=" str)
1340         (cons
1341          'bytes
1342          (map (lambda (x)
1343                 (let ((dash (string-index x #\-)))
1344                   (cond
1345                    ((not dash)
1346                     (bad-header 'range str))
1347                    ((zero? dash)
1348                     (cons #f (parse-non-negative-integer x 1)))
1349                    ((= dash (1- (string-length x)))
1350                     (cons (parse-non-negative-integer x 0 dash) #f))
1351                    (else
1352                     (cons (parse-non-negative-integer x 0 dash)
1353                           (parse-non-negative-integer x (1+ dash)))))))
1354               (string-split (substring str 6) #\,)))
1355         (bad-header 'range str)))
1356   (lambda (val)
1357     (and (pair? val)
1358          (symbol? (car val))
1359          (list-of? (cdr val)
1360                    (lambda (elt)
1361                      (and (pair? elt)
1362                           (let ((x (car elt)) (y (cdr elt)))
1363                             (and (or x y)
1364                                  (or (not x) (non-negative-integer? x))
1365                                  (or (not y) (non-negative-integer? y)))))))))
1366   (lambda (val port)
1367     (display (car val) port)
1368     (display #\= port)
1369     (write-list
1370      (cdr val) port
1371      (lambda (pair port)
1372        (if (car pair)
1373            (display (car pair) port))
1374        (display #\- port)
1375        (if (cdr pair)
1376            (display (cdr pair) port)))
1377      ",")))
1378
1379 ;; Referer = ( absoluteURI | relativeURI )
1380 ;;
1381 (declare-uri-header referer
1382   "Referer")
1383
1384 ;; TE = #( t-codings )
1385 ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
1386 ;;
1387 (declare-param-list-header te
1388   "TE"
1389   (lambda (k) (if (equal? k "trailers") 'trailers k)))
1390
1391 ;; User-Agent = 1*( product | comment )
1392 ;;
1393 (declare-opaque-header user-agent
1394   "User-Agent")
1395
1396
1397 \f
1398
1399 ;;;
1400 ;;; Reponse headers
1401 ;;;
1402
1403 ;; Accept-Ranges = acceptable-ranges
1404 ;; acceptable-ranges = 1#range-unit | "none"
1405 ;;
1406 (declare-string-list-header accept-ranges
1407   "Accept-Ranges")
1408
1409 ;; Age = age-value
1410 ;; age-value = delta-seconds
1411 ;;
1412 (declare-integer-header age
1413   "Age")
1414
1415 ;; ETag = entity-tag
1416 ;;
1417 (declare-header etag
1418   "ETag"
1419   parse-entity-tag
1420   entity-tag?
1421   write-entity-tag)
1422
1423 ;; Location = absoluteURI
1424 ;;
1425 (declare-uri-header location
1426   "Location")
1427
1428 ;; Proxy-Authenticate = 1#challenge
1429 ;;
1430 ;; FIXME: split challenges ?
1431 (declare-opaque-header proxy-authenticate
1432   "Proxy-Authenticate")
1433
1434 ;; Retry-After  = ( HTTP-date | delta-seconds )
1435 ;;
1436 (declare-header retry-after
1437   "Retry-After"
1438   (lambda (str)
1439     (if (and (not (string-null? str))
1440              (char-numeric? (string-ref str 0)))
1441         (parse-non-negative-integer str)
1442         (parse-date str)))
1443   (lambda (val)
1444     (or (date? val) (non-negative-integer? val)))
1445   (lambda (val port)
1446     (if (date? val)
1447         (write-date val port)
1448         (display val port))))
1449
1450 ;; Server = 1*( product | comment )
1451 ;;
1452 (declare-opaque-header server
1453   "Server")
1454
1455 ;; Vary = ( "*" | 1#field-name )
1456 ;;
1457 (declare-header vary
1458   "Vary"
1459   (lambda (str)
1460     (if (equal? str "*")
1461         '*
1462         (split-and-trim str)))
1463   (lambda (val)
1464     (or (eq? val '*) (list-of-strings? val)))
1465   (lambda (val port)
1466     (if (eq? val '*)
1467         (display "*" port)
1468         (write-list-of-strings val port))))
1469
1470 ;; WWW-Authenticate = 1#challenge
1471 ;;
1472 ;; Hum.
1473 (declare-opaque-header www-authenticate
1474   "WWW-Authenticate")