[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-50-gd9
From: |
Andy Wingo |
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-50-gd9f00c3 |
Date: |
Sat, 13 Nov 2010 17:28:14 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d9f00c3db598955db75047aa805adf16a7bb2421
The branch, master has been updated
via d9f00c3db598955db75047aa805adf16a7bb2421 (commit)
via 3d9597799100171aee43cc02ca985fe35920a5c3 (commit)
via 7aa54882cfa399fcf7214cb7c95cf50deb436d84 (commit)
from 190fa72a8f7013b864c1e9196d54c8344e4d0a59 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d9f00c3db598955db75047aa805adf16a7bb2421
Author: Andy Wingo <address@hidden>
Date: Sat Nov 13 18:31:34 2010 +0100
flesh out (web server)'s sanitize-response
* module/web/server.scm (sanitize-response): Flesh out. If we get a
string, we encode it to a bytevector using the encoding snarfed from
the response. We should check the request, though...
commit 3d9597799100171aee43cc02ca985fe35920a5c3
Author: Andy Wingo <address@hidden>
Date: Sat Nov 13 18:30:27 2010 +0100
add extend-response.
* module/web/response.scm (extend-response): New utility.
commit 7aa54882cfa399fcf7214cb7c95cf50deb436d84
Author: Andy Wingo <address@hidden>
Date: Sat Nov 13 18:17:28 2010 +0100
(web http) parses content-type as "foo/bar", not "foo" "bar"
* module/web/http.scm (parse-media-type, validate-media-type,
(content-type): Change to represent media types as ("foo/bar" ("param"
. "val") ...) instead of ("foo" "bar" ("param" . "val") ...). Seems to
be more in line with what people expect.
* test-suite/tests/web-http.test ("entity headers"): Add content-type
test.
* test-suite/tests/web-response.test ("example-1"): Adapt expected
parse.
-----------------------------------------------------------------------
Summary of changes:
module/web/http.scm | 63 ++++++++++++++++++-----------------
module/web/response.scm | 13 +++++++
module/web/server.scm | 38 +++++++++++++++++++++-
test-suite/tests/web-http.test | 8 +---
test-suite/tests/web-response.test | 4 +-
5 files changed, 86 insertions(+), 40 deletions(-)
diff --git a/module/web/http.scm b/module/web/http.scm
index 5245cca..5063aa9 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -199,15 +199,16 @@
(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 separators-without-slash
+ (string->char-set "[^][()<>@,;:\\\"?= \t]"))
+(define (validate-media-type str)
+ (let ((idx (string-index str #\/)))
+ (and idx (= idx (string-rindex str #\/))
+ (not (string-index str separators-without-slash)))))
(define (parse-media-type str)
- (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))))
+ (if (validate-media-type str)
+ str
+ (bad-header-component 'media-type str)))
(define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
(let lp ((i start))
@@ -1139,32 +1140,32 @@
"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)))))))
+ (cons (parse-media-type (car parts))
+ (map (lambda (x)
+ (let ((eq (string-index x #\=)))
+ (if (and eq (= eq (string-rindex x #\=)))
+ (cons (string-trim x char-whitespace? 0 eq)
+ (string-trim-right x char-whitespace? (1+ eq)))
+ (bad-header 'content-type str))))
+ (cdr parts)))))
(lambda (val)
- (and (list-of? val string?)
- (let ((len (length val)))
- (and (>= len 2)
- (even? len)))))
+ (and (pair? val)
+ (string? (car val))
+ (list-of? (cdr val)
+ (lambda (x)
+ (and (pair? x) (string? (car x)) (string? (cdr x)))))))
(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))
- ";")))
+ (if (pair? (cdr val))
+ (begin
+ (display ";" port)
+ (write-list
+ (cdr val) port
+ (lambda (pair port)
+ (display (car pair) port)
+ (display #\= port)
+ (display (cdr pair) port))
+ ";")))))
;; Expires = HTTP-date
;;
diff --git a/module/web/response.scm b/module/web/response.scm
index c205485..1c0ba3d 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -33,6 +33,7 @@
response-port
read-response
build-response
+ extend-response
write-response
read-response-body/latin-1
@@ -95,6 +96,18 @@
(headers '()) port)
(make-response version code reason-phrase headers port))
+(define (extend-response r k v . additional)
+ (let ((r (build-response #:version (response-version r)
+ #:code (response-code r)
+ #:reason-phrase (%response-reason-phrase r)
+ #:headers
+ (assoc-set! (copy-tree (response-headers r))
+ k v)
+ #:port (response-port r))))
+ (if (null? additional)
+ r
+ (apply extend-response r additional))))
+
(define *reason-phrases*
'((100 . "Continue")
(101 . "Switching Protocols")
diff --git a/module/web/server.scm b/module/web/server.scm
index 2e7ad0c..83997d7 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -156,9 +156,45 @@
(warn "Error handling request" k args)
(apply values (build-response #:code 500) #f state))))
+(define (encode-string str charset)
+ (case charset
+ ((utf-8) (string->utf8 str))
+ (else (error "unknown charset" charset))))
+
;; -> response body
(define (sanitize-response request response body)
- (values response body))
+ (cond
+ ((list? response)
+ (sanitize-response request (build-response #:headers response) body))
+ ((string? body)
+ (let* ((type (response-content-type response
+ '("text/plain")))
+ (declared-charset (assoc-ref (cdr type) "charset"))
+ (charset (if declared-charset
+ (string->symbol
+ (string-downcase declared-charset))
+ 'utf-8)))
+ (sanitize-response
+ request
+ (if declared-charset
+ response
+ (extend-response response 'content-type
+ `(,@type ("charset" . ,(symbol->string charset)))))
+ (encode-string body charset))))
+ ((procedure? body)
+ (sanitize-response request response (call-with-output-string body)))
+ ((bytevector? body)
+ ;; check length; assert type; add other required fields?
+ (values (let ((len (response-content-length response)))
+ (if len
+ (if (= len (bytevector-length body))
+ response
+ (error "bad content-length" len (bytevector-length
body)))
+ (extend-response response 'content-length
+ (bytevector-length body))))
+ body))
+ (else
+ (error "unexpected body type"))))
;; -> (#f | client)
(define (write-client impl server client response body)
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index dfc181c..5085668 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -121,6 +121,8 @@
(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 content-type "foo/bar" '("foo/bar"))
+ (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"
(string->date "Tue, 15 Nov 1994 08:12:31 +0000"
"~a, ~d ~b ~Y ~H:~M:~S ~z"))
@@ -128,12 +130,6 @@
(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))
diff --git a/test-suite/tests/web-response.test
b/test-suite/tests/web-response.test
index 540e16d..41cd3d1 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -35,7 +35,7 @@ Expires: Thu, 28 Oct 2010 15:33:13 GMT\r
Vary: Accept-Encoding\r
Content-Encoding: gzip\r
Content-Length: 36\r
-Content-Type: text/html\r
+Content-Type: text/html; charset=utf-8\r
\r
abcdefghijklmnopqrstuvwxyz0123456789")
@@ -79,7 +79,7 @@ abcdefghijklmnopqrstuvwxyz0123456789")
(vary . ("Accept-Encoding"))
(content-encoding . ("gzip"))
(content-length . 36)
- (content-type . ("text" "html")))))
+ (content-type . ("text/html" ("charset" . "utf-8"))))))
(pass-if "write then read"
(call-with-values
hooks/post-receive
--
GNU Guile
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-50-gd9f00c3,
Andy Wingo <=