Package: guile;
Reported by: mason1920 <clone1920 <at> gmail.com>
Date: Sun, 1 Jan 2023 08:36:03 UTC
Severity: normal
Tags: patch
To reply to this bug, email your comments to 60461 AT debbugs.gnu.org.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
bug-guile <at> gnu.org:bug#60461; Package guile.
(Sun, 01 Jan 2023 08:36:03 GMT) Full text and rfc822 format available.mason1920 <clone1920 <at> gmail.com>:bug-guile <at> gnu.org.
(Sun, 01 Jan 2023 08:36:03 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: mason1920 <clone1920 <at> gmail.com> To: bug-guile <at> gnu.org Cc: mason1920 <mason1920 <at> protonmail.com> Subject: [PATCH] Improve compliance of HTTP challenge parsing 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.