bug#10109: [PATCH] (web http): list-style headers do not validate

[Daniel Hartwig <mandyke@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 3356 bytes --]

Package: guile
Version: 2.0.3
Tags: patch

Many of the list-style headers from (web http) do not validate
correctly.  The test suite only checks that the header's parse and
does not test the associated validators.

Attached is a very quick patch (0002) which exposes the failing
validators through the test-suite:

$ ./guile-test tests/web-http.test
Running tests/web-http.test
...
FAIL: tests/web-http.test: general headers: cache-control:
"no-transform" -> (no-transform)
FAIL: tests/web-http.test: general headers: cache-control:
"no-transform,foo" -> (no-transform foo)
FAIL: tests/web-http.test: general headers: cache-control: "no-cache"
-> (no-cache)
FAIL: tests/web-http.test: general headers: cache-control:
"no-cache=\"Authorization, Date\"" -> ((no-cache authorization date))
FAIL: tests/web-http.test: general headers: cache-control:
"private=\"Foo\"" -> ((private foo))
FAIL: tests/web-http.test: general headers: cache-control:
"no-cache,max-age=10" -> (no-cache (max-age . 10))
FAIL: tests/web-http.test: general headers: pragma: "no-cache" -> (no-cache)
FAIL: tests/web-http.test: general headers: pragma: "no-cache, foo" ->
(no-cache foo)
FAIL: tests/web-http.test: general headers: transfer-encoding: "foo,
chunked" -> ((foo) (chunked))
FAIL: tests/web-http.test: entity headers: allow: "foo, bar" -> (foo bar)
FAIL: tests/web-http.test: entity headers: content-encoding: "qux,
baz" -> (qux baz)
FAIL: tests/web-http.test: request headers: accept: "text/*;q=0.3,
text/html;q=0.7, text/html;level=1" -> ((text/* (q . 300)) (text/html
(q . 700)) (text/html (level . "1")))
FAIL: tests/web-http.test: request headers: authorization: "Basic
foooo" -> (basic . "foooo")
FAIL: tests/web-http.test: request headers: authorization: "Digest
foooo" -> (digest foooo)
FAIL: tests/web-http.test: request headers: expect: "100-continue,
foo" -> ((#{100-continue}#) (foo))
FAIL: tests/web-http.test: request headers: proxy-authorization:
"Basic foooo" -> (basic . "foooo")
FAIL: tests/web-http.test: request headers: proxy-authorization:
"Digest foooo" -> (digest foooo)
FAIL: tests/web-http.test: request headers: te: "trailers" -> ((trailers))
FAIL: tests/web-http.test: request headers: te: "trailers,foo" ->
((trailers) (foo))
FAIL: tests/web-http.test: response headers: accept-ranges: "foo,bar"
-> (foo bar)

Totals for this test run:
passes:                 60
failures:               20
...


The other patch (0001) corrects `http.scm' for some typos and missing logic,
after which the above failures no longer occur.

$ ./guile-test tests/web-http.test
Running tests/web-http.test
...

Totals for this test run:
passes:                 80
failures:               0
...


0001 (web http): fix validators for various list-style headers

* module/web/http.scm (default-val-validator): Valid with no value.
  (key-value-list?): Keys are always symbols, do not accept strings.
  (validate-param-list): Apply `valid?' to list elements.
  (validate-credentials): Validate param for Basic scheme, which
  is parsed as a string.
  (declare-symbol-list-header!): `list-of?' args were in wrong order.
  ("Cache-Control"): Replace `default-val-validator' with more
  specific procedure.
  ("Accept"): Validate on first param which has no value.
---
 module/web/http.scm |   26 ++++++++++++++++++--------
 1 files changed, 18 insertions(+), 8 deletions(-)

[-- Attachment #2: 0001-web-http-fix-validators-for-various-list-style-heade.patch --]
[-- Type: text/x-patch, Size: 2487 bytes --]

diff --git a/module/web/http.scm b/module/web/http.scm
index e8765f3..dc742a1 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -470,7 +470,7 @@ ordered alist."
   val)
 
 (define (default-val-validator k val)
-  (string? val))
+  (or (not val) (string? val)))
 
 (define (default-val-writer k val port)
   (if (or (string-index val #\;)
@@ -518,9 +518,9 @@ ordered alist."
                ((pair? elt)
                 (let ((k (car elt))
                       (v (cdr elt)))
-                  (and (or (string? k) (symbol? k))
+                  (and (symbol? k)
                        (valid? k v))))
-               ((or (string? elt) (symbol? elt))
+               ((symbol? elt)
                 (valid? elt #f))
                (else #f)))))
 
@@ -611,7 +611,7 @@ ordered alist."
                               (valid? default-val-validator))
   (list-of? list
             (lambda (elt)
-              (key-value-list? list valid?))))
+              (key-value-list? elt valid?))))
 
 (define* (write-param-list list port #:optional
                            (val-writer default-val-writer))
@@ -871,7 +871,10 @@ ordered alist."
          (cons scheme (parse-key-value-list str default-val-parser delim end)))))))
 
 (define (validate-credentials val)
-  (and (pair? val) (symbol? (car val)) (key-value-list? (cdr val))))
+  (and (pair? val) (symbol? (car val))
+       (case (car val)
+         ((basic) (string? (cdr val)))
+         (else (key-value-list? (cdr val))))))
 
 (define (write-credentials val port)
   (display (car val) port)
@@ -1137,7 +1140,7 @@ phrase\"."
     (lambda (str)
       (map string->symbol (split-and-trim str)))
     (lambda (v)
-      (list-of? symbol? v))
+      (list-of? v symbol?))
     (lambda (v port)
       (write-list v port display ", "))))
 
@@ -1242,7 +1245,14 @@ phrase\"."
       ((private no-cache)
        (and v-str (split-header-names v-str)))
       (else v-str)))
-  default-val-validator
+  (lambda (k v)
+    (case k
+      ((max-age max-stale min-fresh s-maxage)
+       (non-negative-integer? v))
+      ((private no-cache)
+       (or (not v) (list-of-header-names? v)))
+      (else
+       (not v))))
   (lambda (k v port)
     (cond
      ((string? v) (display v port))
@@ -1522,7 +1532,7 @@ phrase\"."
   (lambda (k v)
     (if (eq? k 'q)
         (valid-quality? v)
-        (string? v)))
+        (or (not v) (string? v))))
   (lambda (k v port)
     (if (eq? k 'q)
         (write-quality v port)

[-- Attachment #3: 0002-web-http-test.patch --]
[-- Type: text/x-patch, Size: 531 bytes --]

diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index e4d6efb..b6abbf3 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -41,8 +41,9 @@
   (syntax-rules ()
     ((_ sym str val)
      (pass-if (format #f "~a: ~s -> ~s" 'sym str val)
-       (equal? (parse-header 'sym str)
-               val)))))
+       (and (equal? (parse-header 'sym str)
+                    val)
+            (valid-header? 'sym val))))))
 
 (define-syntax pass-if-any-error
   (syntax-rules ()