leniency regarding quality values in http.scm

* module/web/http.scm: Add commentary.
  (parse-quality): Allow .NNN to be interpreted as 0.NNN.

* test-suite/tests/web-http.test ("request headers"): Add a test.

diff --git a/module/web/http.scm b/module/web/http.scm
index bf54b23..6416b1b 100644 (file)
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -17,6 +17,16 @@
 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 ;; 02110-1301 USA
 
+;;; Commentary:
+;;;
+;;; This module has a number of routines to parse textual
+;;; representations of HTTP data into native Scheme data structures.
+;;;
+;;; It tries to follow RFCs fairly strictly---the road to perdition
+;;; being paved with compatibility hacks---though some allowances are
+;;; made for not-too-divergent texts (like a quality of .2 which should
+;;; be 0.2, etc).
+;;;
 ;;; Code:
 
 (define-module (web http)
@@ -316,6 +326,16 @@
                           (+ q (* place (char->decimal (string-ref str i))))
                           q))))
             (bad-header-component 'quality str))))
+   ;; Allow the nonstandard .2 instead of 0.2.
+   ((and (eqv? (string-ref str start) #\.)
+         (< 1 (- end start) 5))
+    (let lp ((place 1) (i (+ start 3)) (q 0))
+      (if (= i start)
+          q
+          (lp (* 10 place) (1- i)
+              (if (< i end)
+                  (+ q (* place (char->decimal (string-ref str i))))
+                  q)))))
    (else
     (bad-header-component 'quality str))))
 

diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 5085668..4d1fe6c 100644 (file)
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -143,6 +143,8 @@
                    (0 . "*")))
   (pass-if-parse accept-language "da, en-gb;q=0.8, en;q=0.7"
                  '((1000 . "da") (800 . "en-gb") (700 . "en")))
+  ;; Allow nonstandard .2 to mean 0.2
+  (pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb")))
   (pass-if-parse authorization "foo" "foo")
   (pass-if-parse expect "100-continue, foo" '((100-continue) ("foo")))
   (pass-if-parse from "foo@bar" "foo@bar")