ETag list headers accept sloppy etags

* module/web/http.scm (parse-entity-tag): Add #:sloppy-delimiters
  keyword argument, and return a second value indicating the end
  position.
  (parse-entity-tag-list): Use parse-entity-tag, so that we also accept
  sloppy etags that aren't qstrings.
* test-suite/tests/web-http.test ("request headers"): Add a test.

module/web/http.scm

@@ -872,11 +872,27 @@ as an ordered alist."
 ;; tag should really be a qstring.  However there are a number of
 ;; servers that emit etags as unquoted strings.  Assume that if the
 ;; value doesn't start with a quote, it's an unquoted strong etag.
-(define (parse-entity-tag val)
+(define* (parse-entity-tag val #:optional (start 0) (end (string-length val))
+                           #:key sloppy-delimiters)
+  (define (parse-proper-etag-at start strong?)
+    (cond
+     (sloppy-delimiters
+      (call-with-values (lambda ()
+                          (parse-qstring val start end #:incremental? #t))
+        (lambda (tag next)
+          (values (cons tag strong?) next))))
+     (else
+      (values (cons (parse-qstring val start end) strong?) end))))
   (cond
-   ((string-prefix? "W/" val) (cons (parse-qstring val 2) #f))
+   ((string-prefix? "W/" val 0 2 start end)
-   ((string-prefix? "\"" val) (cons (parse-qstring val) #t))
+    (parse-proper-etag-at (+ start 2) #f))
-   (else (cons val #t))))
+   ((string-prefix? "\"" val 0 1 start end)
+    (parse-proper-etag-at start #t))
+   (else
+    (let ((delim (or (and sloppy-delimiters
+                          (string-index val sloppy-delimiters start end))
+                     end)))
+      (values (cons (substring val start delim) #t) delim)))))
 
 (define (entity-tag? val)
   (and (pair? val)
@@ -889,21 +905,19 @@ as an ordered alist."
 
 (define* (parse-entity-tag-list val #:optional
                                 (start 0) (end (string-length val)))
-  (let ((strong? (not (string-prefix? "W/" val 0 2 start end))))
+  (call-with-values (lambda ()
-    (call-with-values (lambda ()
+                      (parse-entity-tag val start end #:sloppy-delimiters #\,))
-                        (parse-qstring val (if strong? start (+ start 2))
+    (lambda (etag next)
-                                       end #:incremental? #t))
+      (cons etag
-      (lambda (tag next)
+            (let ((next (skip-whitespace val next end)))
-        (acons tag strong?
+              (if (< next end)
-               (let ((next (skip-whitespace val next end)))
+                  (if (eqv? (string-ref val next) #\,)
-                  (if (< next end)
+                      (parse-entity-tag-list
-                      (if (eqv? (string-ref val next) #\,)
+                       val
-                          (parse-entity-tag-list
+                       (skip-whitespace val (1+ next) end)
-                           val
+                       end)
-                           (skip-whitespace val (1+ next) end)
+                      (bad-header-component 'entity-tag-list val))
-                           end)
+                  '()))))))
-                          (bad-header-component 'entity-tag-list val))
-                      '())))))))
 
 (define (entity-tag-list? val)
   (list-of? val entity-tag?))

test-suite/tests/web-http.test

@@ -331,6 +331,8 @@
                          "~a, ~d ~b ~Y ~H:~M:~S ~z"))
   (pass-if-parse if-none-match "\"xyzzy\", W/\"qux\""
                  '(("xyzzy" . #t) ("qux" . #f)))
+  (pass-if-parse if-none-match "xyzzy, W/\"qux\""
+                 '(("xyzzy" . #t) ("qux" . #f)))
   (pass-if-parse if-none-match "*" '*)
   (pass-if-parse if-range "\"foo\"" '("foo" . #t))
   (pass-if-parse if-range  "Tue, 15 Nov 1994 08:12:31 GMT"