guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 01/01: ETag list headers accept sloppy etags


From: Andy Wingo
Subject: [Guile-commits] 01/01: ETag list headers accept sloppy etags
Date: Sun, 28 Aug 2016 11:48:50 +0000 (UTC)

wingo pushed a commit to branch master
in repository guile.

commit 342bd8dfb325eab6610e7c4450aaf810ef71884f
Author: Andy Wingo <address@hidden>
Date:   Sun Aug 28 13:46:31 2016 +0200

    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            |   52 +++++++++++++++++++++++++---------------
 test-suite/tests/web-http.test |    2 ++
 2 files changed, 35 insertions(+), 19 deletions(-)

diff --git a/module/web/http.scm b/module/web/http.scm
index 8e95fc7..c9fb195 100644
--- a/module/web/http.scm
+++ b/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? "\"" val) (cons (parse-qstring val) #t))
-   (else (cons val #t))))
+   ((string-prefix? "W/" val 0 2 start end)
+    (parse-proper-etag-at (+ start 2) #f))
+   ((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 ()
-                        (parse-qstring val (if strong? start (+ start 2))
-                                       end #:incremental? #t))
-      (lambda (tag next)
-        (acons tag strong?
-               (let ((next (skip-whitespace val next end)))
-                  (if (< next end)
-                      (if (eqv? (string-ref val next) #\,)
-                          (parse-entity-tag-list
-                           val
-                           (skip-whitespace val (1+ next) end)
-                           end)
-                          (bad-header-component 'entity-tag-list val))
-                      '())))))))
+  (call-with-values (lambda ()
+                      (parse-entity-tag val start end #:sloppy-delimiters #\,))
+    (lambda (etag next)
+      (cons etag
+            (let ((next (skip-whitespace val next end)))
+              (if (< next end)
+                  (if (eqv? (string-ref val next) #\,)
+                      (parse-entity-tag-list
+                       val
+                       (skip-whitespace val (1+ next) end)
+                       end)
+                      (bad-header-component 'entity-tag-list val))
+                  '()))))))
 
 (define (entity-tag-list? val)
   (list-of? val entity-tag?))
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 3fda4f9..762f78c 100644
--- a/test-suite/tests/web-http.test
+++ b/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"



reply via email to

[Prev in Thread] Current Thread [Next in Thread]