more symbols in (web http)

* module/web/http.scm (declare-symbol-list-header!): New helper.
  ("Connection"): Redefine as a header list.
  ("Allow", "Content-Encoding", "Accept-Ranges"): Redefine as symbol
  lists.

* test-suite/tests/web-http.test:
* test-suite/tests/web-response.test: Adapt tests.

diff --git a/module/web/http.scm b/module/web/http.scm
index 2c1e93a..d211714 100644 (file)
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -860,6 +860,16 @@ phrase\"."
   (declare-header! name
     split-and-trim list-of-strings? write-list-of-strings))
 
+;; emacs: (put 'declare-symbol-list-header! 'scheme-indent-function 1)
+(define (declare-symbol-list-header! name)
+  (declare-header! name
+    (lambda (str)
+      (map string->symbol (split-and-trim str)))
+    (lambda (v)
+      (list-of? symbol? v))
+    (lambda (v port)
+      (write-list v port display ", "))))
+
 ;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1)
 (define (declare-header-list-header! name)
   (declare-header! name
@@ -969,7 +979,7 @@ phrase\"."
 ;; e.g.
 ;;     Connection: close, foo-header
 ;; 
-(declare-string-list-header! "Connection")
+(declare-header-list-header! "Connection")
 
 ;; Date  = "Date" ":" HTTP-date
 ;; e.g.
@@ -1090,11 +1100,11 @@ phrase\"."
 
 ;; Allow = #Method
 ;;
-(declare-string-list-header! "Allow")
+(declare-symbol-list-header! "Allow")
 
 ;; Content-Encoding = 1#content-coding
 ;;
-(declare-string-list-header! "Content-Encoding")
+(declare-symbol-list-header! "Content-Encoding")
 
 ;; Content-Language = 1#language-tag
 ;;
@@ -1407,7 +1417,7 @@ phrase\"."
 ;; Accept-Ranges = acceptable-ranges
 ;; acceptable-ranges = 1#range-unit | "none"
 ;;
-(declare-string-list-header! "Accept-Ranges")
+(declare-symbol-list-header! "Accept-Ranges")
 
 ;; Age = age-value
 ;; age-value = delta-seconds

diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index aa7ddf6..ecefe7c 100644 (file)
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -83,8 +83,8 @@
   (pass-if-parse cache-control "no-cache,max-age=10"
                  '(no-cache (max-age . 10)))
 
-  (pass-if-parse connection "close" '("close"))
-  (pass-if-parse connection "close, foo" '("close" "foo"))
+  (pass-if-parse connection "close" '(close))
+  (pass-if-parse connection "Content-Encoding" '(content-encoding))
 
   (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT"
                  (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
@@ -114,8 +114,8 @@
                          "~a, ~d ~b ~Y ~H:~M:~S ~z")))))
 
 (with-test-prefix "entity headers"
-  (pass-if-parse allow "foo, bar" '("foo" "bar"))
-  (pass-if-parse content-encoding "qux, baz" '("qux" "baz"))
+  (pass-if-parse allow "foo, bar" '(foo bar))
+  (pass-if-parse content-encoding "qux, baz" '(qux baz))
   (pass-if-parse content-language "qux, baz" '("qux" "baz"))
   (pass-if-parse content-length "100" 100)
   (pass-if-parse content-length "0" 0)
@@ -187,7 +187,7 @@
 ;; Response headers
 ;;
 (with-test-prefix "response headers"
-  (pass-if-parse accept-ranges "foo,bar" '("foo" "bar"))
+  (pass-if-parse accept-ranges "foo,bar" '(foo bar))
   (pass-if-parse age "30" 30)
   (pass-if-parse etag "\"foo\"" '("foo" . #t))
   (pass-if-parse etag "W/\"foo\"" '("foo" . #f))

diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test
index 278b0b3..7e7331e 100644 (file)
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -72,12 +72,12 @@ abcdefghijklmnopqrstuvwxyz0123456789")
        `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000"
                                 "~a, ~d ~b ~Y ~H:~M:~S ~z"))
          (server . "Apache/2.0.55")
-         (accept-ranges . ("bytes"))
+         (accept-ranges . (bytes))
          (cache-control . ((max-age . 543234)))
          (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000"
                                    "~a, ~d ~b ~Y ~H:~M:~S ~z"))
          (vary . (accept-encoding))
-         (content-encoding . ("gzip"))
+         (content-encoding . (gzip))
          (content-length . 36)
          (content-type . (text/html (charset . "utf-8"))))))
     
@@ -96,4 +96,4 @@ abcdefghijklmnopqrstuvwxyz0123456789")
           (responses-equal? r body r* body*))))
 
     (pass-if "by accessor"
-      (equal? (response-content-encoding r) '("gzip")))))
+      (equal? (response-content-encoding r) '(gzip)))))