Subject: bug#60461: [PATCH] Improve compliance of HTTP challenge parsing

From: mason1920 <[email-masked]>
Date: Sat, 31 Dec 2022 12:30:45 -0500

* module/web/http.scm (parse-challenges, validate-challenges)
(write-challenges): Make challenge arguments optional. Add support
for encoded values as challenge argument.
* test-suite/tests/web-http.test (Response Headers): Test valid
challenges that were not being handled before.
---
 module/web/http.scm            | 127 +++++++++++++++------------------
 test-suite/tests/web-http.test |  14 ++--
 2 files changed, 69 insertions(+), 72 deletions(-)

diff --git a/module/web/http.scm b/module/web/http.scm
index 29736f2..69cb819 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -30,7 +30,7 @@
 ;;; Code:
 
 (define-module (web http)
-  #:use-module ((srfi srfi-1) #:select (append-map! map!))
+  #:use-module ((srfi srfi-1) #:select (append-map! map! every))
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
   #:use-module (ice-9 rdelim)
@@ -39,6 +39,7 @@
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 textual-ports)
   #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 peg)
   #:use-module (rnrs bytevectors)
   #:use-module (web uri)
   #:export (string->header
@@ -986,73 +987,63 @@ as an ordered alist."
      (write-key-value-list params port))))
 
 ;; challenges = 1#challenge
-;; challenge = auth-scheme 1*SP 1#auth-param
-;;
-;; A pain to parse, as both challenges and auth params are delimited by
-;; commas, and qstrings can contain anything. We rely on auth params
-;; necessarily having "=" in them.
-;;
-(define* (parse-challenge str #:optional
-                          (start 0) (end (string-length str)))
-  (let* ((start (skip-whitespace str start end))
-         (sp (string-index str #\space start end))
-         (scheme (if sp
-                     (string->symbol (string-downcase (substring str start sp)))
-                     (bad-header-component 'challenge str))))
-    (let lp ((i sp) (out (list scheme)))
-      (if (not (< i end))
-          (values (reverse! out) end)
-          (let* ((i (skip-whitespace str i end))
-                 (eq (string-index str #\= i end))
-                 (comma (string-index str #\, i end))
-                 (delim (min (or eq end) (or comma end)))
-                 (token-end (trim-whitespace str i delim)))
-            (if (string-index str #\space i token-end)
-                (values (reverse! out) i)
-                (let ((k (string->symbol (substring str i token-end))))
-                  (call-with-values
-                      (lambda ()
-                        (if (and eq (or (not comma) (< eq comma)))
-                            (let ((i (skip-whitespace str (1+ eq) end)))
-                              (if (and (< i end) (eqv? (string-ref str i) #\"))
-                                  (parse-qstring str i end #:incremental? #t)
-                                  (values (substring
-                                           str i
-                                           (trim-whitespace str i
-                                                            (or comma end)))
-                                          (or comma end))))
-                            (values #f delim)))
-                    (lambda (v next-i)
-                      (let ((i (skip-whitespace str next-i end)))
-                        (unless (or (= i end) (eqv? (string-ref str i) #\,))
-                          (bad-header-component 'challenge
-                                                (substring str start end)))
-                        (lp (1+ i) (cons (if v (cons k v) k) out))))))))))))
-
-(define* (parse-challenges str #:optional (val-parser default-val-parser)
-                           (start 0) (end (string-length str)))
-  (let lp ((i start))
-    (let ((i (skip-whitespace str i end)))
-      (if (< i end)
-          (call-with-values (lambda () (parse-challenge str i end))
-            (lambda (challenge i)
-              (cons challenge (lp i))))
-          '()))))
-
-(define (validate-challenges val)
-  (match val
-    ((((? symbol?) . (? key-value-list?)) ...) #t)
-    (_ #f)))
-
-(define (put-challenge port val)
-  (match val
-    ((scheme . params)
-     (put-symbol port scheme)
-     (put-char port #\space)
-     (write-key-value-list params port))))
-
-(define (write-challenges val port)
-  (put-list port val put-challenge ", "))
+;; challenge = auth-scheme [ 1*SP encoded / 1#auth-param ]
+(define (parse-challenges str)
+  (define-peg-string-patterns
+"challenges <-- ls* (challenge (&(ls+ challenge) ls+)?)+ ls* !.
+challenge <-- sym (space (args/encoded)?)?
+encoded <-- token68 '='*
+args <-- ls* (arg (&(ls+ arg) ls+)?)+
+arg <-- sym equals value
+equals < whitespace? '=' whitespace?
+value <-- token/quoted
+quoted <- dquote (!dquote escape? .)* dquote
+sym <-- token
+dquote < '\"'
+escape < '\\'
+ls < whitespace? ',' whitespace?
+space < ' '+
+whitespace < [ \t]+
+token <- (common/[!#$%^&*`'|])+
+token68 <- (common/'/')+
+common <- [A-Za-z0-9._~+]/'-'")
+
+  (define match (or
+    (match-pattern challenges str)
+    (bad-header-component 'challenge str)))
+
+  (let build ((tree (peg:tree match))) (cond
+      ((null? tree) (list))
+      ((list? (car tree)) (build (car tree)))
+      (#t (case (car tree)
+        ; Ordered map so tests can easily compare resulting structure.
+        ((challenges args) (map-in-order build (cdr tree)))
+        ((challenge arg) (cons (build (cadr tree)) (build (cddr tree))))
+        ((sym) (string-ci->symbol (cadr tree)))
+        ((encoded value) (cadr tree)))))))
+
+(define validate-challenges (match-lambda
+  (((type . arg) ..1) (every (lambda (type arg) (and
+    (symbol? type)
+    (or
+      (string? arg)
+      (match arg
+        (((name . val) ..1) (every (lambda (name val) (and
+          (symbol? name)
+          (string? val))) name val))
+        (() #t)
+        (_ #f))))) type arg))
+  (_ #f)))
+
+(define (write-challenges challenges port)
+  (put-list port challenges
+    (lambda (port challenge)
+      (put-symbol port (car challenge))
+      (put-char port #\space)
+      (if (list? (cdr challenge))
+        (write-key-value-list (cdr challenge) port default-val-writer ",")
+        (put-string port (cdr challenge))))
+    ","))

 
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 06dd947..efbc50c 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -416,8 +416,6 @@
                  (build-uri-reference #:path "/foo"))
   (pass-if-parse location "//server/foo"
                  (build-uri-reference #:host "server" #:path "/foo"))
-  (pass-if-parse proxy-authenticate "Basic realm=\"guile\""
-                 '((basic (realm . "guile"))))
   (pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT"
                  (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
                          "~a, ~d ~b ~Y ~H:~M:~S ~z"))
@@ -425,8 +423,16 @@
   (pass-if-parse server "guile!" "guile!")
   (pass-if-parse vary "*" '*)
   (pass-if-parse vary "foo, bar" '(foo bar))
-  (pass-if-parse www-authenticate "Basic realm=\"guile\""
-                 '((basic (realm . "guile")))))
+  (pass-if-parse www-authenticate "type" '((type)))
+  (pass-if-any-error www-authenticate " type")
+  (pass-if-parse www-authenticate " , \t type,," '((type)))
+  (pass-if-parse www-authenticate "type   " '((type)))
+  (pass-if-parse www-authenticate "type  encoded====" '((type . "encoded====")))
+  (pass-if-parse www-authenticate "type name= \t value" '((type (name . "value"))))
+  (pass-if-parse www-authenticate "type name=\"quoted  =  \\\"value\""
+                 '((type (name . "quoted  =  \"value"))))
+  (pass-if-parse www-authenticate "t0, t1 e,, \t  t2 n0=v0, n1=\"v\\1\""
+                 '((t0) (t1 . "e") (t2 (n0 . "v0") (n1 . "v1")))))
 
 (with-test-prefix "chunked encoding"
   (let* ((s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n\r\n")
-- 
2.37.3