* bug#60461: [PATCH] Improve compliance of HTTP challenge parsing
@ 2022-12-31 17:30 mason1920
0 siblings, 0 replies; only message in thread
From: mason1920 @ 2022-12-31 17:30 UTC (permalink / raw)
To: 60461; +Cc: mason1920
* 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))))
+ ","))
\f
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
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2022-12-31 17:30 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-12-31 17:30 bug#60461: [PATCH] Improve compliance of HTTP challenge parsing mason1920
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).