mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

(web http): keys are always symbols

Browse source 
* module/web/http.scm (parse-media-type): Parse media types as symbols.
  (parse-key-value-list, parse-param-component, parse-param-list):
  Change kons to val-parser. Always parse keys as symbols, and always
  either cons, if there is a val, or just have the key, if there is no
  val.  Easier to explain and just as correct.
  (declare-param-list-header!, declare-key-value-list-header!): Adapt to
  key-list and param-list kons change.
  ("Cache-Control", "Pragma", "Transfer-Encoding", "Accept", "Expect")
  ("TE"): Likewise, adapt.
  ("Content-Type"): Param keys are symbols.
This commit is contained in:
Andy Wingo 2011-01-08 20:50:46 -08:00
parent 32de1aa783
commit 0acc595b94
7 changed files with 83 additions and 100 deletions
Download patch file Download diff file Expand all files Collapse all files

4
examples/web/debug-sxml.scm
View file

@ -30,8 +30,8 @@
(status 200) (status 200)
(title default-title) (title default-title)
(doctype html5-doctype) (doctype html5-doctype)
(content-type-params '(("charset" . "utf-8"))) (content-type-params '((charset . "utf-8")))
(content-type "text/html") (content-type 'text/html)
(extra-headers '()) (extra-headers '())
(sxml (and body (templatize #:title title #:body body)))) (sxml (and body (templatize #:title title #:body body))))
(values (build-response (values (build-response

2
examples/web/hello.scm
View file

@ -23,7 +23,7 @@
;; for us with a 200 OK status. ;; for us with a 200 OK status.
;; ;;
(define (handler request body) (define (handler request body)
(values '((content-type . ("text/plain"))) (values '((content-type . (text/plain)))
"Hello, World!")) "Hello, World!"))
(run-server handler) (run-server handler)

117
module/web/http.scm
View file

@ -258,7 +258,7 @@ ordered alist."
(not (string-index str separators-without-slash))))) (not (string-index str separators-without-slash)))))
(define (parse-media-type str) (define (parse-media-type str)
(if (validate-media-type str) (if (validate-media-type str)
str (string->symbol str)
(bad-header-component 'media-type str))) (bad-header-component 'media-type str)))
(define* (skip-whitespace str #:optional (start 0) (end (string-length str))) (define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
@ -467,13 +467,11 @@ ordered alist."
(define (non-negative-integer? code) (define (non-negative-integer? code)
(and (number? code) (>= code 0) (exact? code) (integer? code))) (and (number? code) (>= code 0) (exact? code) (integer? code)))
(define (default-kons k val) (define (default-val-parser k val)
(if val val)
(cons k val)
k))
(define (default-kv-validator k val) (define (default-val-validator k val)
#t) (string? val))
(define (default-val-writer k val port) (define (default-val-writer k val port)
(if (or (string-index val #\;) (if (or (string-index val #\;)
@ -482,8 +480,8 @@ ordered alist."
(write-qstring val port) (write-qstring val port)
(display val port))) (display val port)))
(define* (parse-key-value-list str #:optional (kproc identity) (define* (parse-key-value-list str #:optional
(kons default-kons) (val-parser default-val-parser)
(start 0) (end (string-length str))) (start 0) (end (string-length str)))
(let lp ((i start) (out '())) (let lp ((i start) (out '()))
(if (not (< i end)) (if (not (< i end))
@ -492,7 +490,8 @@ ordered alist."
(eq (string-index str #\= i end)) (eq (string-index str #\= i end))
(comma (string-index str #\, i end)) (comma (string-index str #\, i end))
(delim (min (or eq end) (or comma end))) (delim (min (or eq end) (or comma end)))
(k (kproc (substring str i (trim-whitespace str i delim))))) (k (string->symbol
(substring str i (trim-whitespace str i delim)))))
(call-with-values (call-with-values
(lambda () (lambda ()
(if (and eq (or (not comma) (< eq comma))) (if (and eq (or (not comma) (< eq comma)))
@ -505,14 +504,15 @@ ordered alist."
(or comma end)))) (or comma end))))
(values #f delim))) (values #f delim)))
(lambda (v-str next-i) (lambda (v-str next-i)
(let ((i (skip-whitespace str next-i end))) (let ((v (val-parser k v-str))
(i (skip-whitespace str next-i end)))
(if (or (= i end) (eqv? (string-ref str i) #\,)) (if (or (= i end) (eqv? (string-ref str i) #\,))
(lp (1+ i) (cons (kons k v-str) out)) (lp (1+ i) (cons (if v (cons k v) k) out))
(bad-header-component 'key-value-list (bad-header-component 'key-value-list
(substring str start end)))))))))) (substring str start end))))))))))
(define* (key-value-list? list #:optional (define* (key-value-list? list #:optional
(valid? default-kv-validator)) (valid? default-val-validator))
(list-of? list (list-of? list
(lambda (elt) (lambda (elt)
(cond (cond
@ -542,8 +542,8 @@ ordered alist."
;; param-component = token [ "=" (token | quoted-string) ] \ ;; param-component = token [ "=" (token | quoted-string) ] \
;; *(";" token [ "=" (token | quoted-string) ]) ;; *(";" token [ "=" (token | quoted-string) ])
;; ;;
(define* (parse-param-component str #:optional (kproc identity) (define* (parse-param-component str #:optional
(kons default-kons) (val-parser default-val-parser)
(start 0) (end (string-length str))) (start 0) (end (string-length str)))
(let lp ((i start) (out '())) (let lp ((i start) (out '()))
(if (not (< i end)) (if (not (< i end))
@ -551,7 +551,7 @@ ordered alist."
(let ((delim (string-index str (let ((delim (string-index str
(lambda (c) (memq c '(#\, #\; #\=))) (lambda (c) (memq c '(#\, #\; #\=)))
i))) i)))
(let ((k (kproc (let ((k (string->symbol
(substring str i (trim-whitespace str i (or delim end))))) (substring str i (trim-whitespace str i (or delim end)))))
(delimc (and delim (string-ref str delim)))) (delimc (and delim (string-ref str delim))))
(case delimc (case delimc
@ -573,7 +573,8 @@ ordered alist."
(values (substring str i delim) (values (substring str i delim)
delim))))) delim)))))
(lambda (v-str next-i) (lambda (v-str next-i)
(let ((x (kons k v-str)) (let* ((v (val-parser k v-str))
(x (if v (cons k v) k))
(i (skip-whitespace str next-i end))) (i (skip-whitespace str next-i end)))
(case (and (< i end) (string-ref str i)) (case (and (< i end) (string-ref str i))
((#f) ((#f)
@ -584,19 +585,21 @@ ordered alist."
(else ; including #\, (else ; including #\,
(values (reverse! (cons x out)) i))))))) (values (reverse! (cons x out)) i)))))))
((#\;) ((#\;)
(let ((v (val-parser k #f)))
(lp (skip-whitespace str (1+ delim) end) (lp (skip-whitespace str (1+ delim) end)
(cons (kons k #f) out))) (cons (if v (cons k v) k) out))))
(else ;; either the end of the string or a #\, (else ;; either the end of the string or a #\,
(values (reverse! (cons (kons k #f) out)) (let ((v (val-parser k #f)))
(or delim end))))))))) (values (reverse! (cons (if v (cons k v) k) out))
(or delim end))))))))))
(define* (parse-param-list str #:optional (define* (parse-param-list str #:optional
(kproc identity) (kons default-kons) (val-parser default-val-parser)
(start 0) (end (string-length str))) (start 0) (end (string-length str)))
(let lp ((i start) (out '())) (let lp ((i start) (out '()))
(call-with-values (call-with-values
(lambda () (parse-param-component str kproc kons i end)) (lambda () (parse-param-component str val-parser i end))
(lambda (item i) (lambda (item i)
(if (< i end) (if (< i end)
(if (eqv? (string-ref str i) #\,) (if (eqv? (string-ref str i) #\,)
@ -606,7 +609,7 @@ ordered alist."
(reverse! (cons item out))))))) (reverse! (cons item out)))))))
(define* (validate-param-list list #:optional (define* (validate-param-list list #:optional
(valid? default-kv-validator)) (valid? default-val-validator))
(list-of? list (list-of? list
(lambda (elt) (lambda (elt)
(key-value-list? list valid?)))) (key-value-list? list valid?))))
@ -881,23 +884,21 @@ phrase\"."
;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1) ;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1)
(define* (declare-param-list-header! name #:optional (define* (declare-param-list-header! name #:optional
(kproc identity) (val-parser default-val-parser)
(kons default-kons) (val-validator default-val-validator)
(val-validator default-kv-validator)
(val-writer default-val-writer)) (val-writer default-val-writer))
(declare-header! name (declare-header! name
(lambda (str) (parse-param-list str kproc kons)) (lambda (str) (parse-param-list str val-parser))
(lambda (val) (validate-param-list val val-validator)) (lambda (val) (validate-param-list val val-validator))
(lambda (val port) (write-param-list val port val-writer)))) (lambda (val port) (write-param-list val port val-writer))))
;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1) ;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1)
(define* (declare-key-value-list-header! name #:optional (define* (declare-key-value-list-header! name #:optional
(kproc identity) (val-parser default-val-parser)
(kons default-kons) (val-validator default-val-validator)
(val-validator default-kv-validator)
(val-writer default-val-writer)) (val-writer default-val-writer))
(declare-header! name (declare-header! name
(lambda (str) (parse-key-value-list str kproc kons)) (lambda (str) (parse-key-value-list str val-parser))
(lambda (val) (key-value-list? val val-validator)) (lambda (val) (key-value-list? val val-validator))
(lambda (val port) (write-key-value-list val port val-writer)))) (lambda (val port) (write-key-value-list val port val-writer))))
@ -943,24 +944,14 @@ phrase\"."
;; cache-extension = token [ "=" ( token | quoted-string ) ] ;; cache-extension = token [ "=" ( token | quoted-string ) ]
;; ;;
(declare-key-value-list-header! "Cache-Control" (declare-key-value-list-header! "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) (lambda (k v-str)
(case k (case k
((max-age max-stale min-fresh s-maxage) ((max-age max-stale min-fresh s-maxage)
(cons k (parse-non-negative-integer v-str))) (parse-non-negative-integer v-str))
((private no-cache) ((private no-cache)
(if v-str (and v-str (split-header-names v-str)))
(cons k (split-header-names v-str)) (else v-str)))
k)) default-val-validator
(else (if v-str (cons k v-str) k))))
default-kv-validator
(lambda (k v port) (lambda (k v port)
(cond (cond
((string? v) (display v port)) ((string? v) (display v port))
@ -990,8 +981,7 @@ phrase\"."
;; pragma-directive = "no-cache" | extension-pragma ;; pragma-directive = "no-cache" | extension-pragma
;; extension-pragma = token [ "=" ( token | quoted-string ) ] ;; extension-pragma = token [ "=" ( token | quoted-string ) ]
;; ;;
(declare-key-value-list-header! "Pragma" (declare-key-value-list-header! "Pragma")
(lambda (k) (if (equal? k "no-cache") 'no-cache k)))
;; Trailer = "Trailer" ":" 1#field-name ;; Trailer = "Trailer" ":" 1#field-name
;; ;;
@ -999,9 +989,7 @@ phrase\"."
;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding ;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding
;; ;;
(declare-param-list-header! "Transfer-Encoding" (declare-param-list-header! "Transfer-Encoding")
(lambda (k)
(if (equal? k "chunked") 'chunked k)))
;; Upgrade = "Upgrade" ":" 1#product ;; Upgrade = "Upgrade" ":" 1#product
;; ;;
@ -1185,16 +1173,17 @@ phrase\"."
(map (lambda (x) (map (lambda (x)
(let ((eq (string-index x #\=))) (let ((eq (string-index x #\=)))
(if (and eq (= eq (string-rindex x #\=))) (if (and eq (= eq (string-rindex x #\=)))
(cons (string-trim x char-whitespace? 0 eq) (cons (string->symbol
(string-trim x char-whitespace? 0 eq))
(string-trim-right x char-whitespace? (1+ eq))) (string-trim-right x char-whitespace? (1+ eq)))
(bad-header 'content-type str)))) (bad-header 'content-type str))))
(cdr parts))))) (cdr parts)))))
(lambda (val) (lambda (val)
(and (pair? val) (and (pair? val)
(string? (car val)) (symbol? (car val))
(list-of? (cdr val) (list-of? (cdr val)
(lambda (x) (lambda (x)
(and (pair? x) (string? (car x)) (string? (cdr x))))))) (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
(lambda (val port) (lambda (val port)
(display (car val) port) (display (car val) port)
(if (pair? (cdr val)) (if (pair? (cdr val))
@ -1230,20 +1219,19 @@ phrase\"."
;; accept-extension = ";" token [ "=" ( token | quoted-string ) ] ;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
;; ;;
(declare-param-list-header! "Accept" (declare-param-list-header! "Accept"
;; -> ("type/subtype" (str-prop . str-val) ...) ...) ;; -> (type/subtype (sym-prop . str-val) ...) ...)
;; ;;
;; with the exception of prop = "q", in which case the prop will be ;; with the exception of prop `q', in which case the val will be a
;; the symbol 'q, and the val will be a valid quality value ;; valid quality value
;; ;;
(lambda (k) (if (string=? k "q") 'q k))
(lambda (k v) (lambda (k v)
(if (eq? k 'q) (if (eq? k 'q)
(cons k (parse-quality v)) (parse-quality v)
(default-kons k v))) v))
(lambda (k v) (lambda (k v)
(if (eq? k 'q) (if (eq? k 'q)
(valid-quality? v) (valid-quality? v)
(default-kv-validator k v))) (string? v)))
(lambda (k v port) (lambda (k v port)
(if (eq? k 'q) (if (eq? k 'q)
(write-quality v port) (write-quality v port)
@ -1276,11 +1264,7 @@ phrase\"."
;; *expect-params ] ;; *expect-params ]
;; expect-params = ";" token [ "=" ( token | quoted-string ) ] ;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
;; ;;
(declare-param-list-header! "Expect" (declare-param-list-header! "Expect")
(lambda (k)
(if (equal? k "100-continue")
'100-continue
k)))
;; From = mailbox ;; From = mailbox
;; ;;
@ -1407,8 +1391,7 @@ phrase\"."
;; TE = #( t-codings ) ;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
;; ;;
(declare-param-list-header! "TE" (declare-param-list-header! "TE")
(lambda (k) (if (equal? k "trailers") 'trailers k)))
;; User-Agent = 1*( product | comment ) ;; User-Agent = 1*( product | comment )
;; ;;

16
module/web/server.scm
View file

@ -1,6 +1,6 @@
;;; Web server ;;; Web server
;; Copyright (C) 2010 Free Software Foundation, Inc. ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -219,27 +219,27 @@ on the procedure being called at any particular time."
(values response #vu8())) (values response #vu8()))
((string? body) ((string? body)
(let* ((type (response-content-type response (let* ((type (response-content-type response
'("text/plain"))) '(text/plain)))
(declared-charset (assoc-ref (cdr type) "charset")) (declared-charset (assq-ref (cdr type) 'charset))
(charset (or declared-charset "utf-8"))) (charset (or declared-charset "utf-8")))
(sanitize-response (sanitize-response
request request
(if declared-charset (if declared-charset
response response
(extend-response response 'content-type (extend-response response 'content-type
`(,@type ("charset" . ,charset)))) `(,@type (charset . ,charset))))
(encode-string body charset)))) (encode-string body charset))))
((procedure? body) ((procedure? body)
(let* ((type (response-content-type response (let* ((type (response-content-type response
'("text/plain"))) '(text/plain)))
(declared-charset (assoc-ref (cdr type) "charset")) (declared-charset (assq-ref (cdr type) 'charset))
(charset (or declared-charset "utf-8"))) (charset (or declared-charset "utf-8")))
(sanitize-response (sanitize-response
request request
(if declared-charset (if declared-charset
response response
(extend-response response 'content-type (extend-response response 'content-type
`(,@type ("charset" . ,charset)))) `(,@type (charset . ,charset))))
(call-with-encoded-output-string charset body)))) (call-with-encoded-output-string charset body))))
((bytevector? body) ((bytevector? body)
;; check length; assert type; add other required fields? ;; check length; assert type; add other required fields?
@ -370,7 +370,7 @@ For example, here is a simple \"Hello, World!\" server:
@example @example
(define (handler request body) (define (handler request body)
(values '((content-type . (\"text/plain\"))) (values '((content-type . (text/plain)))
\"Hello, World!\")) \"Hello, World!\"))
(run-server handler) (run-server handler)
@end example @end example

20
test-suite/tests/web-http.test
View file

@ -74,7 +74,7 @@
(with-test-prefix "general headers" (with-test-prefix "general headers"
(pass-if-parse cache-control "no-transform" '(no-transform)) (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-transform,foo" '(no-transform foo))
(pass-if-parse cache-control "no-cache" '(no-cache)) (pass-if-parse cache-control "no-cache" '(no-cache))
(pass-if-parse cache-control "no-cache=\"Authorization, Date\"" (pass-if-parse cache-control "no-cache=\"Authorization, Date\""
'((no-cache . (authorization date)))) '((no-cache . (authorization date))))
@ -93,12 +93,12 @@
(pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST") (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" '(no-cache))
(pass-if-parse pragma "no-cache, foo" '(no-cache "foo")) (pass-if-parse pragma "no-cache, foo" '(no-cache foo))
(pass-if-parse trailer "foo, bar" '(foo bar)) (pass-if-parse trailer "foo, bar" '(foo bar))
(pass-if-parse trailer "connection, bar" '(connection bar)) (pass-if-parse trailer "connection, bar" '(connection bar))
(pass-if-parse transfer-encoding "foo, chunked" '(("foo") (chunked))) (pass-if-parse transfer-encoding "foo, chunked" '((foo) (chunked)))
(pass-if-parse upgrade "qux" '("qux")) (pass-if-parse upgrade "qux" '("qux"))
@ -125,8 +125,8 @@
(pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *)) (pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *))
(pass-if-parse content-range "bytes */*" '(bytes * *)) (pass-if-parse content-range "bytes */*" '(bytes * *))
(pass-if-parse content-range "bytes */30" '(bytes * 30)) (pass-if-parse content-range "bytes */30" '(bytes * 30))
(pass-if-parse content-type "foo/bar" '("foo/bar")) (pass-if-parse content-type "foo/bar" '(foo/bar))
(pass-if-parse content-type "foo/bar; baz=qux" '("foo/bar" ("baz" . "qux"))) (pass-if-parse content-type "foo/bar; baz=qux" '(foo/bar (baz . "qux")))
(pass-if-parse expires "Tue, 15 Nov 1994 08:12:31 GMT" (pass-if-parse expires "Tue, 15 Nov 1994 08:12:31 GMT"
(string->date "Tue, 15 Nov 1994 08:12:31 +0000" (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
"~a, ~d ~b ~Y ~H:~M:~S ~z")) "~a, ~d ~b ~Y ~H:~M:~S ~z"))
@ -136,9 +136,9 @@
(with-test-prefix "request headers" (with-test-prefix "request headers"
(pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1" (pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1"
'(("text/*" (q . 300)) '((text/* (q . 300))
("text/html" (q . 700)) (text/html (q . 700))
("text/html" ("level" . "1")))) (text/html (level . "1"))))
(pass-if-parse accept-charset "iso-8859-5, unicode-1-1;q=0.8" (pass-if-parse accept-charset "iso-8859-5, unicode-1-1;q=0.8"
'((1000 . "iso-8859-5") (800 . "unicode-1-1"))) '((1000 . "iso-8859-5") (800 . "unicode-1-1")))
(pass-if-parse accept-encoding "gzip;q=1.0, identity; q=0.5, *;q=0" (pass-if-parse accept-encoding "gzip;q=1.0, identity; q=0.5, *;q=0"
@ -150,7 +150,7 @@
;; Allow nonstandard .2 to mean 0.2 ;; Allow nonstandard .2 to mean 0.2
(pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb"))) (pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb")))
(pass-if-parse authorization "foo" "foo") (pass-if-parse authorization "foo" "foo")
(pass-if-parse expect "100-continue, foo" '((100-continue) ("foo"))) (pass-if-parse expect "100-continue, foo" '((100-continue) (foo)))
(pass-if-parse from "foo@bar" "foo@bar") (pass-if-parse from "foo@bar" "foo@bar")
(pass-if-parse host "qux" '("qux" . #f)) (pass-if-parse host "qux" '("qux" . #f))
(pass-if-parse host "qux:80" '("qux" . 80)) (pass-if-parse host "qux:80" '("qux" . 80))
@ -180,7 +180,7 @@
(pass-if-parse referer "http://foo/bar?baz" (pass-if-parse referer "http://foo/bar?baz"
(build-uri 'http #:host "foo" #:path "/bar" #:query "baz")) (build-uri 'http #:host "foo" #:path "/bar" #:query "baz"))
(pass-if-parse te "trailers" '((trailers))) (pass-if-parse te "trailers" '((trailers)))
(pass-if-parse te "trailers,foo" '((trailers) ("foo"))) (pass-if-parse te "trailers,foo" '((trailers) (foo)))
(pass-if-parse user-agent "guile" "guile")) (pass-if-parse user-agent "guile" "guile"))

14
test-suite/tests/web-request.test
View file

@ -1,6 +1,6 @@
;;;; web-request.test --- HTTP requests -*- mode: scheme; coding: utf-8; -*- ;;;; web-request.test --- HTTP requests -*- mode: scheme; coding: utf-8; -*-
;;;; ;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -61,12 +61,12 @@ Accept-Language: en-gb, en;q=0.9\r
(request-headers r) (request-headers r)
'((host . ("localhost" . 8080)) '((host . ("localhost" . 8080))
(user-agent . "Mozilla/5.0 (X11; U; Linux x86_64; en-us) AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2") (user-agent . "Mozilla/5.0 (X11; U; Linux x86_64; en-us) AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2")
(accept . (("application/xml") (accept . ((application/xml)
("application/xhtml+xml") (application/xhtml+xml)
("text/html" (q . 900)) (text/html (q . 900))
("text/plain" (q . 800)) (text/plain (q . 800))
("image/png") (image/png)
("*/*" (q . 500)))) (*/* (q . 500))))
(accept-encoding . ((1000 . "gzip"))) (accept-encoding . ((1000 . "gzip")))
(accept-language . ((1000 . "en-gb") (900 . "en")))))) (accept-language . ((1000 . "en-gb") (900 . "en"))))))

4
test-suite/tests/web-response.test
View file

@ -1,6 +1,6 @@
;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*- ;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*-
;;;; ;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -79,7 +79,7 @@ abcdefghijklmnopqrstuvwxyz0123456789")
(vary . (accept-encoding)) (vary . (accept-encoding))
(content-encoding . ("gzip")) (content-encoding . ("gzip"))
(content-length . 36) (content-length . 36)
(content-type . ("text/html" ("charset" . "utf-8")))))) (content-type . (text/html (charset . "utf-8"))))))
(pass-if "write then read" (pass-if "write then read"
(call-with-values (call-with-values