From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: mason1920 Newsgroups: gmane.lisp.guile.bugs Subject: bug#60461: [PATCH] Improve compliance of HTTP challenge parsing Date: Sat, 31 Dec 2022 12:30:45 -0500 Message-ID: <20221231173045.10081-1-mason1920@protonmail.com> Mime-Version: 1.0 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="30372"; mail-complaints-to="usenet@ciao.gmane.io" Cc: mason1920 To: 60461@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Sun Jan 01 09:36:52 2023 Return-path: Envelope-to: guile-bugs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1pBtps-0007mv-DS for guile-bugs@m.gmane-mx.org; Sun, 01 Jan 2023 09:36:52 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1pBtp7-0003rU-8m; Sun, 01 Jan 2023 03:36:05 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1pBtp5-0003qs-RV for bug-guile@gnu.org; Sun, 01 Jan 2023 03:36:03 -0500 Original-Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1pBtp5-0005xv-IA for bug-guile@gnu.org; Sun, 01 Jan 2023 03:36:03 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1pBtp5-0001Dx-Dt for bug-guile@gnu.org; Sun, 01 Jan 2023 03:36:03 -0500 X-Loop: help-debbugs@gnu.org Resent-From: mason1920 Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Sun, 01 Jan 2023 08:36:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 60461 X-GNU-PR-Package: guile X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-guile@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.16725621364631 (code B ref -1); Sun, 01 Jan 2023 08:36:03 +0000 Original-Received: (at submit) by debbugs.gnu.org; 1 Jan 2023 08:35:36 +0000 Original-Received: from localhost ([127.0.0.1]:40251 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1pBtoa-0001CU-OE for submit@debbugs.gnu.org; Sun, 01 Jan 2023 03:35:35 -0500 Original-Received: from lists.gnu.org ([209.51.188.17]:40164) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1pBfho-0000M4-Uw for submit@debbugs.gnu.org; Sat, 31 Dec 2022 12:31:37 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1pBfho-0005un-Ne for bug-guile@gnu.org; Sat, 31 Dec 2022 12:31:36 -0500 Original-Received: from mail-qt1-x835.google.com ([2607:f8b0:4864:20::835]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1pBfhn-0006EI-0v for bug-guile@gnu.org; Sat, 31 Dec 2022 12:31:36 -0500 Original-Received: by mail-qt1-x835.google.com with SMTP id a16so19328072qtw.10 for ; Sat, 31 Dec 2022 09:31:34 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=zByMe2jxgBPEx0dR3jtdrX0LoalIPxom5RaRTp7SrTM=; b=mEFMvvGCQzmWehpq7xl4VQEnLyhBAjn/MaJJFGDv08oP8Tqd7S2FhrD10wnRLveyGI YMTbJETHoHMijEu/l4TD6ElLdvOElvJqXWhKYHKO3wm21aqxiQUVGNziKvSPw815rcGl RFFpMbM5iuDWHWBluJMSriC9heUWi4uACyLv2bIE+dyvt+ESn5lKWtjPGwgQjGDS9E9L ddu2nqbNc+M6kTINrYcnrn86Dyl5cBiUo0kz5dhxH743OA4DJKIdJ2On5itLZSXDnHoO HBGMrsxq1U/sCH2FHn5HJmwzGmb7QnOvj/OfGdV5vHJxkrjI+BXgqbMVW+Gru295Qo2d mU/Q== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=zByMe2jxgBPEx0dR3jtdrX0LoalIPxom5RaRTp7SrTM=; b=Exc20moJyihpBBqptdMXh2rf6Ew2Y9c3gTkRJNHRqeuZjUj+SwB+Z0DbQDdIF1p1gA qUpkfVKqaUvhJsxq5le1ToNpZeheVok/YEicdlheheYSukgGIoye5npwtxGtJgQFTW44 L9Oxg/N3bSn6skiBSA/1Pg4uqxzXDT+fO1hCaxCJx6pBUVC4UHqwFwYikqoBKZvzHEKE f0zk+HXIUfkvpyrTXISaxfhhvgUQS9sdE1hhk7kNTCmAqJwq5IM4ka0d5TFDbSIjVGeJ d0C0VJrGilzt66tX4u8Y05PGBa/jGykj27dcshNduVsk1uScH+EBtxEJ1AZ5HExYFBOE qEaQ== X-Gm-Message-State: AFqh2koUjKbfnCys3id/FyeE4+6BmcvuniWFod9HS9K+ysXvXUjpQktZ GG4UCORdDGURzstTVfroeqUj6oXNWcA= X-Google-Smtp-Source: AMrXdXs+36J+LIvCAYThQ/ZeMMqBoDZAHqX3UIz687pkTIflcPRVq3HVP6trDXsqCjFyuoqwwOuW0g== X-Received: by 2002:ac8:70d7:0:b0:3ab:7928:526c with SMTP id g23-20020ac870d7000000b003ab7928526cmr32174168qtp.17.1672507893462; Sat, 31 Dec 2022 09:31:33 -0800 (PST) Original-Received: from 1920.home (50-32-117-203.adr01.dlls.pa.frontiernet.net. [50.32.117.203]) by smtp.gmail.com with ESMTPSA id h17-20020a05620a401100b006fa9d101775sm17874729qko.33.2022.12.31.09.31.32 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 31 Dec 2022 09:31:33 -0800 (PST) X-Google-Original-From: mason1920 X-Mailer: git-send-email 2.37.3 Received-SPF: pass client-ip=2607:f8b0:4864:20::835; envelope-from=clone1920@gmail.com; helo=mail-qt1-x835.google.com X-Spam_score_int: -17 X-Spam_score: -1.8 X-Spam_bar: - X-Spam_report: (-1.8 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_ENVFROM_END_DIGIT=0.25, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-Mailman-Approved-At: Sun, 01 Jan 2023 03:35:31 -0500 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Original-Sender: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.bugs:10493 Archived-At: * 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