mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 17:50:29 +02:00
Code Activity

(web http) parses content-type as "foo/bar", not "foo" "bar"

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-11-13 18:17:28 +01:00
parent 190fa72a8f
commit 7aa54882cf
3 changed files with 36 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

63
module/web/http.scm
View file

@ -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
;;