Write out HTTP Basic auth headers correctly.

Fixes <http://bugs.gnu.org/14370>.
Reported by Atom X Zane <atomx@deadlyhead.com>.

* module/web/http.scm (write-credentials): Handle the Basic auth scheme
  correctly.

* test-suite/tests/web-http.test (pass-if-round-trip): Use
  'pass-if-equal' for better error reporting.
  ("request headers"): Add tests.

* THANKS: Add "Atom X Zane" to bug fix section.

diff --git a/THANKS b/THANKS
index f16376b..ddb11c1 100644 (file)
--- a/THANKS
+++ b/THANKS
@@ -192,6 +192,7 @@ For fixes or providing information which led to a fix:
            Andy Wingo
           Keith Wright
         William Xu
+         Atom X Zane
 
 
 ;; Local Variables:

diff --git a/module/web/http.scm b/module/web/http.scm
index d22c70c..aa75142 100644 (file)
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -918,10 +918,10 @@ as an ordered alist."
 
 (define (write-credentials val port)
   (display (car val) port)
-  (if (pair? (cdr val))
-      (begin
-        (display #\space port)
-        (write-key-value-list (cdr val) port))))
+  (display #\space port)
+  (case (car val)
+    ((basic) (display (cdr val) port))
+    (else (write-key-value-list (cdr val) port))))
 
 ;; challenges = 1#challenge
 ;; challenge = auth-scheme 1*SP 1#auth-param

diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index aa607af..45cce02 100644 (file)
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -49,14 +49,14 @@
 (define-syntax pass-if-round-trip
   (syntax-rules ()
     ((_ str)
-     (pass-if (format #f "~s round trip" str)
-       (equal? (call-with-output-string
-                (lambda (port)
-                  (call-with-values
-                      (lambda () (read-header (open-input-string str)))
-                    (lambda (sym val)
-                      (write-header sym val port)))))
-               str)))))
+     (pass-if-equal (format #f "~s round trip" str)
+         str
+       (call-with-output-string
+        (lambda (port)
+          (call-with-values
+              (lambda () (read-header (open-input-string str)))
+            (lambda (sym val)
+              (write-header sym val port)))))))))
 
 (define-syntax pass-if-any-error
   (syntax-rules ()
@@ -292,6 +292,9 @@
   (pass-if-parse authorization "Digest foooo" '(digest foooo))
   (pass-if-parse authorization "Digest foo=bar,baz=qux"
                  '(digest (foo . "bar") (baz . "qux")))
+  (pass-if-round-trip "Authorization: basic foooo\r\n")
+  (pass-if-round-trip "Authorization: digest foooo\r\n")
+  (pass-if-round-trip "Authorization: digest foo=bar, baz=qux\r\n")
   (pass-if-parse expect "100-continue, foo" '((100-continue) (foo)))
   (pass-if-parse from "foo@bar" "foo@bar")
   (pass-if-parse host "qux" '("qux" . #f))