diff --git a/module/web/http.scm b/module/web/http.scm index 5245ccad6..5063aa98e 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/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index dfc181c18..5085668fe 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 540e16d58..41cd3d17d 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