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

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

[Daniel Hartwig]

[-- 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 ()

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

[Andy Wingo]

On Tue 22 Nov 2011 19:18, Daniel Hartwig <mandyke@gmail.com> writes:

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

I applied both of your patches.  Thank you very much!

In the future, please make your patches as separate git commits in your
repository.  Then do `git format-patch origin/stable-2.0..HEAD'.  Then
attach the generated files to a mail.  The advantage is that I don't
have to cut and paste your commit log, and I don't have to make special
effort to ensure that you are listed as the author in the commits.

Also, your first patch is probably at the limit of how big a patch we
can accept without getting you to assign copyright to the FSF.  If you
think you will send more patches in the future, it's probably a good
idea to start that process, if you are OK with that.  Email me privately
and I'll tell you how to do that.  Note that GNU has recently entered
the 20th century ;) by sending the forms via PDF.  You can submit them
electronically too, but only if you are a US resident.  Anyway, send me
an email if you are interested.

Thanks again for the patches!

Andy
-- 
http://wingolog.org/

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

[Daniel Hartwig]

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

Hello again

My apologies for not noticing earlier, but I have spotted a couple
minor issues with both the previous patch and original code that are
corrected by the attached. All relate to the "Cache-Control" header:

- `max-stale' has optional value (previous code requires it)
- some directives do not have values (`no-store', etc.)
- there are `cache-extension' directives that may or may not have a value

Attached patch tidies this up, with explicit validation of all defined
directives, though it leaves open one issue with the cache-extension
directives:

;; cache-extension = token [ "=" ( token | quoted-string ) ]
scheme@(web http)> (read-header (open-input-string "Cache-Control:
foo=\"qstring\"\r\n"))
$102 = cache-control
$103 = ((foo . "qstring"))
scheme@(web http)> (write-header 'cache-control $103
(current-output-port)) (newline)
Cache-Control: foo=qstring

You see quotes around `qstring' are dropped, `parse-key-value-list'
appears inadequate to distinguish between a token and quoted-string
when passing values to the `val-parser'.  This looks like it will
raise itself in edge cases for some other headers.  Will file a new
bug if needed after investigation.


Regards

Daniel

On 23 November 2011 02:18, Daniel Hartwig <mandyke@gmail.com> wrote:
> 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)
> [...]

[-- Attachment #2: 0001-Extend-handling-of-Cache-Control-header.patch --]
[-- Type: text/x-patch, Size: 2311 bytes --]

From bf2a00213c60cc47c6c3257a0afe885fca044d27 Mon Sep 17 00:00:00 2001
From: Daniel Hartwig <mandyke@gmail.com>
Date: Sun, 27 Nov 2011 22:37:24 +0800
Subject: [PATCH] Extend handling of "Cache-Control" header.

* module/web/http.scm ("Cache-Control"): Value for `max-stale' is
  optional.  Strict validation for value-less directives (`no-store',
  etc.).  String values optional for "cache-extension" directives.
* test-suite/tests/web-http.test: Value for `max-stale' is optional.
---
 module/web/http.scm            |   12 +++++++++---
 test-suite/tests/web-http.test |    2 ++
 2 files changed, 11 insertions(+), 3 deletions(-)

diff --git a/module/web/http.scm b/module/web/http.scm
index dc742a1..20ea2aa 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1240,19 +1240,25 @@ phrase\"."
 (declare-key-value-list-header! "Cache-Control"
   (lambda (k v-str)
     (case k
-      ((max-age max-stale min-fresh s-maxage)
+      ((max-age min-fresh s-maxage)
        (parse-non-negative-integer v-str))
+      ((max-stale)
+       (and v-str (parse-non-negative-integer v-str)))
       ((private no-cache)
        (and v-str (split-header-names v-str)))
       (else v-str)))
   (lambda (k v)
     (case k
-      ((max-age max-stale min-fresh s-maxage)
+      ((max-age min-fresh s-maxage)
        (non-negative-integer? v))
+      ((max-stale)
+       (or (not v) (non-negative-integer? v)))
       ((private no-cache)
        (or (not v) (list-of-header-names? v)))
+      ((no-store no-transform only-if-cache must-revalidate proxy-revalidate)
+       (not v))
       (else
-       (not v))))
+       (or (not v) (string? v)))))
   (lambda (k v port)
     (cond
      ((string? v) (display v port))
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index b6abbf3..b5247ab 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -83,6 +83,8 @@
                  '((private . (foo))))
   (pass-if-parse cache-control "no-cache,max-age=10"
                  '(no-cache (max-age . 10)))
+  (pass-if-parse cache-control "max-stale" '(max-stale))
+  (pass-if-parse cache-control "max-stale=10" '((max-stale . 10)))
 
   (pass-if-parse connection "close" '(close))
   (pass-if-parse connection "Content-Encoding" '(content-encoding))
-- 
1.7.2.5

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

[Andy Wingo]

On Sun 27 Nov 2011 10:11, Daniel Hartwig <mandyke@gmail.com> writes:

> My apologies for not noticing earlier, but I have spotted a couple
> minor issues with both the previous patch and original code that are
> corrected by the attached. All relate to the "Cache-Control" header:
>
> - `max-stale' has optional value (previous code requires it)
> - some directives do not have values (`no-store', etc.)
> - there are `cache-extension' directives that may or may not have a value
>
> Attached patch tidies this up

Thanks, it was a great patch.  Applied and pushed.

> with explicit validation of all defined
> directives, though it leaves open one issue with the cache-extension
> directives:

I fixed this one, I think.

Happy hacking,

Andy
-- 
http://wingolog.org/