diff options
author | Andy Wingo <wingo@pobox.com> | 2010-10-24 12:36:17 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-11-04 22:52:47 +0100 |
commit | 440840c113c744082b7892315049a4704517215a (patch) | |
tree | 3b3a54cfc9f35e7e7708de8b8c042525e17ccef6 | |
parent | 5a2f7fb3156bbcba5ee5ac818526bf40ed43cfe1 (diff) | |
download | guile-440840c113c744082b7892315049a4704517215a.tar.gz |
add HTTP module
* module/web/http.scm: New module, declares known HTTP headers, and
their parsers and unparsers.
* test-suite/tests/web-http.test: Add test suite.
* module/Makefile.am:
* test-suite/Makefile.am: Adapt.
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/web/http.scm | 1464 | ||||
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/web-http.test | 202 |
4 files changed, 1668 insertions, 0 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index b86123fc4..13e9b3419 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -349,6 +349,7 @@ LIB_SOURCES = \ texinfo/serialize.scm WEB_SOURCES = \ + web/http.scm \ web/uri.scm EXTRA_DIST += oop/ChangeLog-2008 diff --git a/module/web/http.scm b/module/web/http.scm new file mode 100644 index 000000000..6d06a35b2 --- /dev/null +++ b/module/web/http.scm @@ -0,0 +1,1464 @@ +;;; HTTP messages + +;; Copyright (C) 2010 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 + +;;; 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 regex) + #:use-module (ice-9 rdelim) + #:use-module (web uri) + #:export (header-decl? + make-header-decl + header-decl-sym + header-decl-name + header-decl-multiple? + header-decl-parser + header-decl-validator + header-decl-writer + declare-header! + + read-header + parse-header + valid-header? + write-header + + read-headers + write-headers + + 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-record-type <header-decl> + (make-header-decl sym name multiple? parser validator writer) + header-decl? + (sym header-decl-sym) + (name header-decl-name) + (multiple? header-decl-multiple?) + (parser header-decl-parser) + (validator header-decl-validator) + (writer header-decl-writer)) + +;; sym -> header +(define *declared-headers* (make-hash-table)) +;; downcased name -> header +(define *declared-headers-by-name* (make-hash-table)) + +(define* (declare-header! sym name #:key + multiple? + parser + validator + writer) + (if (and (symbol? sym) (string? name) parser validator writer) + (let ((decl (make-header-decl sym name + multiple? parser validator writer))) + (hashq-set! *declared-headers* sym decl) + (hash-set! *declared-headers-by-name* (string-downcase name) decl) + decl) + (error "bad header decl" sym name multiple? parser validator writer))) + +(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 (read-header port) + (let ((line (read-line* port))) + (if (or (string-null? line) + (string=? line "\r")) + (values #f #f) + (let ((delim (or (string-index line #\:) + (bad-header '%read line)))) + (parse-header + (substring line 0 delim) + (read-continuation-line + port + (string-trim-both line char-whitespace? (1+ delim)))))))) + +(define (parse-header name val) + (let* ((down (string-downcase name)) + (decl (hash-ref *declared-headers-by-name* down))) + (if decl + (values (header-decl-sym decl) + ((header-decl-parser decl) val)) + (values down val)))) + +(define (valid-header? sym val) + (let ((decl (hashq-ref *declared-headers* sym))) + (if (not decl) + (error "Unknown header" sym) + ((header-decl-validator decl) val)))) + +(define (write-header name val port) + (if (string? name) + ;; assume that it's a header we don't know about... + (begin + (display name port) + (display ": " port) + (display val port) + (display "\r\n" port)) + (let ((decl (hashq-ref *declared-headers* name))) + (if (not decl) + (error "Unknown header" name) + (begin + (display (header-decl-name decl) port) + (display ": " port) + ((header-decl-writer decl) val port) + (display "\r\n" port)))))) + +(define (read-headers port) + (let lp ((headers '())) + (call-with-values (lambda () (read-header port)) + (lambda (k v) + (if k + (lp (acons k v headers)) + (reverse! headers)))))) + +;; Doesn't write the final \r\n, as the user might want to add another +;; header. +(define (write-headers headers port) + (let lp ((headers headers)) + (if (pair? headers) + (begin + (write-header (caar headers) (cdar headers) port) + (lp (cdr headers)))))) + + + + +;;; +;;; 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 not-separator + "[^][()<>@,;:\\\"/?= \t]") +(define media-type-re + (make-regexp (format #f "^(~a+)/(~a+)$" not-separator not-separator))) +(define (parse-media-type str) + (let ((m (regexp-exec media-type-re str))) + (if m + (values (match:substring m 1) (match:substring m 2)) + (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 (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)))) + (else + (bad-header-component 'quality str)))) + +(define (valid-quality? q) + (and (non-negative-integer? q) (<= 1000 q))) + +(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-kons k val) + (if val + (cons k val) + k)) + +(define (default-kv-validator k val) + #t) + +(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 (kproc identity) + (kons default-kons) + (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 (kproc (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 ((i (skip-whitespace str next-i end))) + (if (or (= i end) (eqv? (string-ref str i) #\,)) + (lp (1+ i) (cons (kons k v-str) out)) + (bad-header-component 'key-value-list + (substring str start end)))))))))) + +(define* (key-value-list? list #:optional + (valid? default-kv-validator)) + (list-of? list + (lambda (elt) + (cond + ((pair? elt) + (let ((k (car elt)) + (v (cdr elt))) + (and (or (string? k) (symbol? k)) + (valid? k v)))) + ((or (string? elt) (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 (kproc identity) + (kons default-kons) + (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 (kproc + (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 ((x (kons k v-str)) + (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))))))) + ((#\;) + (lp (skip-whitespace str (1+ delim) end) + (cons (kons k #f) out))) + + (else ;; either the end of the string or a #\, + (values (reverse! (cons (kons k #f) out)) + (or delim end))))))))) + +(define* (parse-param-list str #:optional + (kproc identity) (kons default-kons) + (start 0) (end (string-length str))) + (let lp ((i start) (out '())) + (call-with-values + (lambda () (parse-param-component str kproc kons 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-kv-validator)) + (list-of? list + (lambda (elt) + (key-value-list? list 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 (list-of-strings? val) + (list-of? val string?)) + +(define (write-list-of-strings val port) + (write-list val port display ", ")) + +(define (parse-date str) + ;; Unfortunately, there is no way to make string->date parse out the + ;; "GMT" bit, so we play string games to append a format it will + ;; understand (the +0000 bit). + (string->date + (if (string-suffix? " GMT" str) + (string-append (substring str 0 (- (string-length str) 4)) + " +0000") + (bad-header-component 'date str)) + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + +(define (write-date date port) + (display (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT") port)) + +(define (write-uri uri port) + (display (unparse-uri uri) 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 (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 ", ")) + + + + +;;; +;;; 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 start end) + (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) + (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-method str start end) + (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-uri-path str start end) + (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 (parse-uri (substring str start end)) + (bad-request "Invalid URI: ~a" (substring str start end)))))) + +(define (read-request-line port) + (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-method line 0 d0) + (parse-uri-path 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) + (display method port) + (display #\space port) + (write-uri uri port) + (display #\space port) + (write-http-version version port) + (display "\r\n" port)) + +(define (read-response-line port) + (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-http-version version port) + (display #\space port) + (display code port) + (display #\space port) + (display reason-phrase port) + (display "\r\n" port)) + + + + +;;; +;;; Syntax for declaring headers +;;; + +;; emacs: (put 'declare-header 'scheme-indent-function 1) +(define-syntax declare-header + (syntax-rules () + ((_ sym name parser validator writer arg ...) + (declare-header! + 'sym name + #:parser parser #:validator validator #:writer writer + arg ...)))) + +;; emacs: (put 'declare-opaque-header 'scheme-indent-function 1) +(define-syntax declare-opaque-header + (syntax-rules () + ((_ sym name) + (declare-header sym + name + parse-opaque-string validate-opaque-string write-opaque-string)))) + +;; emacs: (put 'declare-date-header 'scheme-indent-function 1) +(define-syntax declare-date-header + (syntax-rules () + ((_ sym name) + (declare-header sym + name + parse-date date? write-date)))) + +;; emacs: (put 'declare-string-list-header 'scheme-indent-function 1) +(define-syntax declare-string-list-header + (syntax-rules () + ((_ sym name) + (declare-header sym + name + split-and-trim list-of-strings? write-list-of-strings)))) + +;; emacs: (put 'declare-integer-header 'scheme-indent-function 1) +(define-syntax declare-integer-header + (syntax-rules () + ((_ sym name) + (declare-header sym + name + parse-non-negative-integer non-negative-integer? display)))) + +;; emacs: (put 'declare-uri-header 'scheme-indent-function 1) +(define-syntax declare-uri-header + (syntax-rules () + ((_ sym name) + (declare-header sym + name + (lambda (str) (or (parse-uri str) (bad-header-component 'uri str))) + uri? + write-uri)))) + +;; emacs: (put 'declare-quality-list-header 'scheme-indent-function 1) +(define-syntax declare-quality-list-header + (syntax-rules () + ((_ sym name) + (declare-header sym + name + parse-quality-list validate-quality-list write-quality-list)))) + +;; emacs: (put 'declare-param-list-header 'scheme-indent-function 1) +(define-syntax declare-param-list-header + (syntax-rules () + ((_ sym name) + (declare-param-list-header sym name identity default-kons + default-kv-validator default-val-writer)) + ((_ sym name kproc) + (declare-param-list-header sym name kproc default-kons + default-kv-validator default-val-writer)) + ((_ sym name kproc kons val-validator val-writer) + (declare-header sym + name + (lambda (str) (parse-param-list str kproc kons)) + (lambda (val) (validate-param-list val val-validator)) + (lambda (val port) (write-param-list val port val-writer)))))) + +;; emacs: (put 'declare-key-value-list-header 'scheme-indent-function 1) +(define-syntax declare-key-value-list-header + (syntax-rules () + ((_ sym name) + (declare-key-value-list-header sym name identity default-kons + default-kv-validator default-val-writer)) + ((_ sym name kproc) + (declare-key-value-list-header sym name kproc default-kons + default-kv-validator default-val-writer)) + ((_ sym name kproc kons val-validator val-writer) + (declare-header sym + name + (lambda (str) (parse-key-value-list str kproc kons)) + (lambda (val) (key-value-list? val val-validator)) + (lambda (val port) (write-key-value-list val port val-writer)))))) + +;; emacs: (put 'declare-entity-tag-list-header 'scheme-indent-function 1) +(define-syntax declare-entity-tag-list-header + (syntax-rules () + ((_ sym name) + (declare-header sym + name + (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str))) + (lambda (val) (or (eq? val '*) (entity-tag-list? val))) + (lambda (val port) + (if (eq? val '*) + (display "*" port) + (write-entity-tag-list val port))))))) + + + + +;;; +;;; 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 + "Cache-Control" + (let ((known-directives (make-hash-table))) + (for-each (lambda (s) + (hash-set! known-directives s (string->symbol s))) + '("no-cache" "no-store" "max-age" "max-stale" "min-fresh" + "no-transform" "only-if-cached" "public" "private" + "must-revalidate" "proxy-revalidate" "s-maxage")) + (lambda (k-str) + (hash-ref known-directives k-str k-str))) + (lambda (k v-str) + (case k + ((max-age max-stale min-fresh s-maxage) + (cons k (parse-non-negative-integer v-str))) + ((private no-cache) + (cons k (if v-str (split-and-trim v-str) #t))) + (else (if v-str (cons k v-str) k)))) + default-kv-validator + (lambda (k v port) + (cond + ((string? v) (display v port)) + ((pair? v) + (write-qstring (string-join v ", ") 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-string-list-header connection + "Connection") + +;; Date = "Date" ":" HTTP-date +;; e.g. +;; Date: Tue, 15 Nov 1994 08:12:31 GMT +;; +(declare-date-header date + "Date") + +;; Pragma = "Pragma" ":" 1#pragma-directive +;; pragma-directive = "no-cache" | extension-pragma +;; extension-pragma = token [ "=" ( token | quoted-string ) ] +;; +(declare-key-value-list-header pragma + "Pragma" + (lambda (k) (if (equal? k "no-cache") 'no-cache k))) + +;; Trailer = "Trailer" ":" 1#field-name +;; +(declare-string-list-header trailer + "Trailer") + +;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding +;; +(declare-param-list-header transfer-encoding + "Transfer-Encoding" + (lambda (k) + (if (equal? k "chunked") 'chunked k))) + +;; Upgrade = "Upgrade" ":" 1#product +;; +(declare-string-list-header upgrade + "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 + "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 + "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) + + + + +;;; +;;; Entity headers +;;; + +;; Allow = #Method +;; +(declare-string-list-header allow + "Allow") + +;; Content-Encoding = 1#content-coding +;; +(declare-string-list-header content-encoding + "Content-Encoding") + +;; Content-Language = 1#language-tag +;; +(declare-string-list-header content-language + "Content-Language") + +;; Content-Length = 1*DIGIT +;; +(declare-integer-header content-length + "Content-Length") + +;; Content-Location = ( absoluteURI | relativeURI ) +;; +(declare-uri-header content-location + "Content-Location") + +;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864> +;; +(declare-opaque-header content-md5 + "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 + "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 + "Content-Type" + (lambda (str) + (let ((parts (string-split str #\;))) + (call-with-values (lambda () (parse-media-type (car parts))) + (lambda (type subtype) + (cons* type subtype + (map (lambda (x) + (let ((eq (string-index x #\=))) + (if (and eq (= eq (string-rindex x #\=))) + (cons (string-trim x 0 eq) + (string-trim-right x (1+ eq))) + (bad-header 'content-type str)))) + (cdr parts))))))) + (lambda (val) + (and (list-of? val string?) + (let ((len (length val))) + (and (>= len 2) + (even? len))))) + (lambda (val port) + (display (car val) port) + (display #\/ port) + (display (cadr val) port) + (write-list + (cddr val) port + (lambda (pair port) + (display (car pair) port) + (display #\= port) + (display (cdr pair) port)) + ";"))) + +;; Expires = HTTP-date +;; +(declare-date-header expires + "Expires") + +;; Last-Modified = HTTP-date +;; +(declare-date-header last-modified + "Last-Modified") + + + + +;;; +;;; 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 + "Accept" + ;; -> ("type/subtype" (str-prop . str-val) ...) ...) + ;; + ;; with the exception of prop = "q", in which case the prop will be + ;; the symbol 'q, and the val will be a valid quality value + ;; + (lambda (k) (if (string=? k "q") 'q k)) + (lambda (k v) + (if (eq? k 'q) + (cons k (parse-quality v)) + (default-kons k v))) + (lambda (k v) + (if (eq? k 'q) + (valid-quality? v) + (default-kv-validator k 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-Charset") + +;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] ) +;; codings = ( content-coding | "*" ) +;; +(declare-quality-list-header accept-encoding + "Accept-Encoding") + +;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] ) +;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" ) +;; +(declare-quality-list-header accept-language + "Accept-Language") + +;; Authorization = credentials +;; +;; Authorization is basically opaque to this HTTP stack, we just pass +;; the string value through. +;; +(declare-opaque-header authorization + "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 + "Expect" + (lambda (k) + (if (equal? k "100-continue") + '100-continue + k))) + +;; From = mailbox +;; +;; Should be an email address; we just pass on the string as-is. +;; +(declare-opaque-header from + "From") + +;; Host = host [ ":" port ] +;; +(declare-header host + "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-Match") + +;; If-Modified-Since = HTTP-date +;; +(declare-date-header if-modified-since + "If-Modified-Since") + +;; If-None-Match = ( "*" | 1#entity-tag ) +;; +(declare-entity-tag-list-header if-none-match + "If-None-Match") + +;; If-Range = ( entity-tag | HTTP-date ) +;; +(declare-header if-range + "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 + "If-Unmodified-Since") + +;; Max-Forwards = 1*DIGIT +;; +(declare-integer-header max-forwards + "Max-Forwards") + +;; Proxy-Authorization = credentials +;; +(declare-opaque-header proxy-authorization + "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 + "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 + "Referer") + +;; TE = #( t-codings ) +;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) +;; +(declare-param-list-header te + "TE" + (lambda (k) (if (equal? k "trailers") 'trailers k))) + +;; User-Agent = 1*( product | comment ) +;; +(declare-opaque-header user-agent + "User-Agent") + + + + +;;; +;;; Reponse headers +;;; + +;; Accept-Ranges = acceptable-ranges +;; acceptable-ranges = 1#range-unit | "none" +;; +(declare-string-list-header accept-ranges + "Accept-Ranges") + +;; Age = age-value +;; age-value = delta-seconds +;; +(declare-integer-header age + "Age") + +;; ETag = entity-tag +;; +(declare-header etag + "ETag" + parse-entity-tag + entity-tag? + write-entity-tag) + +;; Location = absoluteURI +;; +(declare-uri-header location + "Location") + +;; Proxy-Authenticate = 1#challenge +;; +;; FIXME: split challenges ? +(declare-opaque-header proxy-authenticate + "Proxy-Authenticate") + +;; Retry-After = ( HTTP-date | delta-seconds ) +;; +(declare-header retry-after + "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 + "Server") + +;; Vary = ( "*" | 1#field-name ) +;; +(declare-header vary + "Vary" + (lambda (str) + (if (equal? str "*") + '* + (split-and-trim str))) + (lambda (val) + (or (eq? val '*) (list-of-strings? val))) + (lambda (val port) + (if (eq? val '*) + (display "*" port) + (write-list-of-strings val port)))) + +;; WWW-Authenticate = 1#challenge +;; +;; Hum. +(declare-opaque-header www-authenticate + "WWW-Authenticate") diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 0fe9c8560..0f352ce38 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -150,6 +150,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/version.test \ tests/vlist.test \ tests/weaks.test \ + tests/web-http.test \ tests/web-uri.test EXTRA_DIST = \ diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test new file mode 100644 index 000000000..dfc181c18 --- /dev/null +++ b/test-suite/tests/web-http.test @@ -0,0 +1,202 @@ +;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Copyright (C) 2010 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 + + +(define-module (test-suite web-http) + #:use-module (web uri) + #:use-module (web http) + #:use-module (ice-9 regex) + #:use-module (ice-9 control) + #:use-module (srfi srfi-19) + #:use-module (test-suite lib)) + + +(define-syntax pass-if-named-exception + (syntax-rules () + ((_ name k pat exp) + (pass-if name + (catch 'k + (lambda () exp (error "expected exception" 'k)) + (lambda (k message args) + (if (string-match pat message) + #t + (error "unexpected exception" message args)))))))) + +(define-syntax pass-if-parse + (syntax-rules () + ((_ sym str val) + (pass-if (format #f "~a: ~s -> ~s" 'sym str val) + (call-with-values (lambda () (parse-header (symbol->string 'sym) str)) + (lambda (k v) + (equal? v val))))))) + +(define-syntax pass-if-any-error + (syntax-rules () + ((_ sym str) + (pass-if (format #f "~a: ~s -> any error" 'sym str) + (% (catch #t + (lambda () + (parse-header (symbol->string 'sym) str) + (abort (lambda () (error "expected exception")))) + (lambda (k . args) + #t)) + (lambda (k thunk) + (thunk))))))) + +(define-syntax pass-if-parse-error + (syntax-rules () + ((_ sym str expected-component) + (pass-if (format #f "~a: ~s -> ~a error" 'sym str 'expected-component) + (catch 'bad-header + (lambda () + (parse-header (symbol->string 'sym) str) + (error "expected exception" 'expected-component)) + (lambda (k component arg) + (if (or (not 'expected-component) + (eq? 'expected-component component)) + #t + (error "unexpected exception" component arg)))))))) + +(with-test-prefix "general headers" + + (pass-if-parse cache-control "no-transform" '(no-transform)) + (pass-if-parse cache-control "no-transform,foo" '(no-transform "foo")) + (pass-if-parse cache-control "no-cache" '((no-cache . #t))) + (pass-if-parse cache-control "no-cache,max-age=10" + '((no-cache . #t) (max-age . 10))) + + (pass-if-parse connection "close" '("close")) + (pass-if-parse connection "close, foo" '("close" "foo")) + + (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date) + (pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST") + + (pass-if-parse pragma "no-cache" '(no-cache)) + (pass-if-parse pragma "no-cache, foo" '(no-cache "foo")) + + (pass-if-parse trailer "foo, bar" '("foo" "bar")) + + (pass-if-parse transfer-encoding "foo, chunked" '(("foo") (chunked))) + + (pass-if-parse upgrade "qux" '("qux")) + + (pass-if-parse via "xyzzy" '("xyzzy")) + + (pass-if-parse warning "123 foo \"core breach imminent\"" + '((123 "foo" "core breach imminent" #f))) + (pass-if-parse + warning + "123 foo \"core breach imminent\" \"Tue, 15 Nov 1994 08:12:31 GMT\"" + `((123 "foo" "core breach imminent" + ,(string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z"))))) + +(with-test-prefix "entity headers" + (pass-if-parse allow "foo, bar" '("foo" "bar")) + (pass-if-parse content-encoding "qux, baz" '("qux" "baz")) + (pass-if-parse content-language "qux, baz" '("qux" "baz")) + (pass-if-parse content-length "100" 100) + (pass-if-parse content-length "0" 0) + (pass-if-parse content-length "010" 10) + (pass-if-parse content-location "http://foo/" + (build-uri 'http #:host "foo" #:path "/")) + (pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *)) + (pass-if-parse content-range "bytes */*" '(bytes * *)) + (pass-if-parse content-range "bytes */30" '(bytes * 30)) + (pass-if-parse expires "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse last-modified "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z"))) + +#; +(parse-header "accept" "text/*;q=0.3, text/html;q=0.7, text/html;level=1") + +#; +(parse-header "expect" "100-continue") + +(with-test-prefix "request headers" + (pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1" + '(("text/*" (q . 300)) + ("text/html" (q . 700)) + ("text/html" ("level" . "1")))) + (pass-if-parse accept-charset "iso-8859-5, unicode-1-1;q=0.8" + '((1000 . "iso-8859-5") (800 . "unicode-1-1"))) + (pass-if-parse accept-encoding "gzip;q=1.0, identity; q=0.5, *;q=0" + '((1000 . "gzip") + (500 . "identity") + (0 . "*"))) + (pass-if-parse accept-language "da, en-gb;q=0.8, en;q=0.7" + '((1000 . "da") (800 . "en-gb") (700 . "en"))) + (pass-if-parse authorization "foo" "foo") + (pass-if-parse expect "100-continue, foo" '((100-continue) ("foo"))) + (pass-if-parse from "foo@bar" "foo@bar") + (pass-if-parse host "qux" '("qux" . #f)) + (pass-if-parse host "qux:80" '("qux" . 80)) + (pass-if-parse if-match "\"xyzzy\", W/\"qux\"" + '(("xyzzy" . #t) ("qux" . #f))) + (pass-if-parse if-match "*" '*) + (pass-if-parse if-modified-since "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse if-none-match "\"xyzzy\", W/\"qux\"" + '(("xyzzy" . #t) ("qux" . #f))) + (pass-if-parse if-none-match "*" '*) + (pass-if-parse if-range "\"foo\"" '("foo" . #t)) + (pass-if-parse if-range "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse if-unmodified-since "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse max-forwards "10" 10) + (pass-if-parse max-forwards "00" 0) + (pass-if-parse proxy-authorization "foo" "foo") + (pass-if-parse range "bytes=10-20" '(bytes (10 . 20))) + (pass-if-parse range "bytes=10-" '(bytes (10 . #f))) + (pass-if-parse range "bytes=-20" '(bytes (#f . 20))) + (pass-if-parse range "bytes=-20,-30" '(bytes (#f . 20) (#f . 30))) + (pass-if-parse referer "http://foo/bar?baz" + (build-uri 'http #:host "foo" #:path "/bar" #:query "baz")) + (pass-if-parse te "trailers" '((trailers))) + (pass-if-parse te "trailers,foo" '((trailers) ("foo"))) + (pass-if-parse user-agent "guile" "guile")) + + +;; Response headers +;; +(with-test-prefix "response headers" + (pass-if-parse accept-ranges "foo,bar" '("foo" "bar")) + (pass-if-parse age "30" 30) + (pass-if-parse etag "\"foo\"" '("foo" . #t)) + (pass-if-parse etag "W/\"foo\"" '("foo" . #f)) + (pass-if-parse location "http://other-place" + (build-uri 'http #:host "other-place")) + (pass-if-parse proxy-authenticate "ho-hum" "ho-hum") + (pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT" + (string->date "Tue, 15 Nov 1994 08:12:31 +0000" + "~a, ~d ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse retry-after "20" 20) + (pass-if-parse server "guile!" "guile!") + (pass-if-parse vary "*" '*) + (pass-if-parse vary "foo, bar" '("foo" "bar")) + (pass-if-parse www-authenticate "secret" "secret")) |