[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-50-gd9f00c3

[Andy Wingo]

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