(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.

diff --git a/module/web/http.scm b/module/web/http.scm
index 5245cca..5063aa9 100644 (file)
--- 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/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index dfc181c..5085668 100644 (file)
--- 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 (file)
--- 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