* 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