From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Vivien Kraus Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 3/3] Parse the HTTP Link header. Date: Sat, 28 Oct 2023 10:51:48 +0200 Message-ID: <091279a8616d296a32a87074cf6450a04766f838.1698483663.git.vivien@planete-kraus.eu> References: Mime-Version: 1.0 Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="9304"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Evolution 3.46.4 Cc: Maxime Devos To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Sat Oct 28 11:04:45 2023 Return-path: Envelope-to: guile-devel@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 1qwfFM-0002Cp-Op for guile-devel@m.gmane-mx.org; Sat, 28 Oct 2023 11:04:44 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1qwfEP-0001Rj-Qb; Sat, 28 Oct 2023 05:03:45 -0400 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 1qwfEO-0001RW-6Z for guile-devel@gnu.org; Sat, 28 Oct 2023 05:03:44 -0400 Original-Received: from planete-kraus.eu ([89.234.140.182]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_CHACHA20_POLY1305:256) (Exim 4.90_1) (envelope-from ) id 1qwfEL-0005W9-Tl for guile-devel@gnu.org; Sat, 28 Oct 2023 05:03:43 -0400 Original-Received: from planete-kraus.eu (localhost.lan [127.0.0.1]) by planete-kraus.eu (OpenSMTPD) with ESMTP id 5699a8fe; Sat, 28 Oct 2023 09:03:37 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=planete-kraus.eu; h= message-id:in-reply-to:references:from:date:subject:to:cc :mime-version; s=albinoniB; bh=2+PIotbot65zz7TCJCjdgy2R5B4=; b=X fzb2jIBlGXD+Uqvt6WySCiRxeOQsJ3fNMitRcXWA0qDJtbvyH3v65RJgB7o7oD6v 9WyYwdDqEGqsbbM4jvcFW/DolQWSopR1VhBBQYd4a+w8X+n5zXEAVlv8jmki6cUu 8OUBYP1F2IVMpCWW8WV4NswqFAk1LpQQkRvT1PrfPYeWh94us7bRh02Ikt7Dam7m ZlN5P9be+j9lioKKIrP60jcfpWPMNGCFqPCEaCiZjADh0anCXKvDYGzL3p9vOWzq 40B6c0jfvC5POqCPFIhLSX1iJ7fURV4WPfAWosNqf1Sef3s/vEqya0HanJXDIT50 UcMhaaDxL6gaAhU34xTzQ== Original-Received: by planete-kraus.eu (OpenSMTPD) with ESMTPSA id 293d2567 (TLSv1.3:TLS_CHACHA20_POLY1305_SHA256:256:NO); Sat, 28 Oct 2023 09:03:37 +0000 (UTC) In-Reply-To: Received-SPF: pass client-ip=89.234.140.182; envelope-from=vivien@planete-kraus.eu; helo=planete-kraus.eu X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 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, PP_MIME_FAKE_ASCII_TEXT=0.001, SPF_HELO_PASS=-0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.devel:22044 Archived-At: The Link header [1] is used to add arbitrary metadata to resources. [1]: https://httpwg.org/specs/rfc8288.html#header * module/web/http.scm (parse-link-value): New function. (parse-link-list): New function. (validate-link-list): New function. (write-link-list): New function. (declare-link-list-header!): New function. ("Link"): Declare the Link header. * test-suite/tests/web-http.test ("general headers"): Add tests for the Link header. * doc/ref/web.texi (HTTP Headers): Document the Link list header type. (link): Document the Link header. * NEWS: Announce the new Link header. * AUTHORS: Update authored files. --- AUTHORS | 4 +- NEWS | 5 +++ doc/ref/web.texi | 17 ++++++++ module/web/http.scm | 80 ++++++++++++++++++++++++++++++++++ test-suite/tests/web-http.test | 36 ++++++++++++++- 5 files changed, 139 insertions(+), 3 deletions(-) diff --git a/AUTHORS b/AUTHORS index 2a95d3b0b..c5f7afd32 100644 --- a/AUTHORS +++ b/AUTHORS @@ -373,8 +373,8 @@ In the subdirectory test-suite/tests, changes to: Vivien Kraus: In the subdirectory module/web, changes to: - uri.scm + uri.scm http.scm In the subdirectory doc/ref, changes to: web.texi In the subdirectory test-suite/tests, changes to: - web-uri.test + web-uri.test web-http.test diff --git a/NEWS b/NEWS index bdf75cb3c..86aa3f4c3 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,11 @@ Changes in 3.0.10 (since 3.0.9) * New interfaces and functionality +** Implementation of the Link HTTP header + +The web API can now parse Link headers, as an alist from URI references +to key-value parameter lists. + ** New function in (web uri): resolve-relative-reference Implement the /5.2. Relative Resolution/ algorithm in RFC 3986. It may diff --git a/doc/ref/web.texi b/doc/ref/web.texi index d92a8d51a..440c58d5a 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -640,6 +640,15 @@ string, and the cdr is @code{#t} if the entity tag is a ``strong'' entity tag, and @code{#f} otherwise. @end deftp +@deftp {HTTP Header Type} LinkList +A list of URI reference links, each one with an optional list of +key-value parameters. The result is a list of pairs. The car of the +pairs are URI references @pxref{Subtypes of URI}, and the cdr of the +pairs are key-value lists: keys are symbols, values are strings. Note +that the Link HTTP header allows URI references as parameter values, +however they are always parsed as strings. +@end deftp + @subsubsection General Headers General HTTP headers may be present in any HTTP message. @@ -684,6 +693,14 @@ The date that a given HTTP message was originated. @end example @end deftypevr +@deftypevr {HTTP Header} LinkList link +A list of links describing the resource. +@example +(parse-header link "; rel=\"http://example.net/foo\"; bar=baz") +@result{} (# (rel . "http://…") (bar . "baz")) +@end example +@end deftypevr + @deftypevr {HTTP Header} KVList pragma A key-value list of implementation-specific directives. @example diff --git a/module/web/http.scm b/module/web/http.scm index b34159aab..ed072edcc 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -637,6 +637,71 @@ as an ordered alist." (write-key-value-list item port val-writer ";")) ",")) +;; link-value = "<" uri-reference ">" (";" param-component)? +(define* (parse-link-value str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let ((uriref-start (+ (string-index str #\<) 1))) + (if uriref-start + (let* ((close-delim + (string-index str #\> uriref-start)) + ((uriref-stop + (or close-delim end))) + (param-start (if close-delim + (+ close-delim 1) + end))) + (let ((link + (false-if-exception + (string->uri-reference + (substring str uriref-start uriref-stop))))) + (unless link + (bad-header-component + 'uri-reference + (substring str uriref-start uriref-stop))) + (call-with-values + (lambda () + (parse-param-component str val-parser param-start end)) + (lambda (parameters param-stop) + (values + `(,link . ,parameters) + param-stop)))))))) + +(define* (parse-link-list str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start) (out '())) + (call-with-values + (lambda () + (parse-link-value str val-parser start end)) + (lambda (item i) + (if (< i end) + (if (eqv? (string-ref str i) #\,) + (lp (skip-whitespace str (1+ i) end) + (cons item out)) + (bad-header-component 'link-list str)) + (reverse! (cons item out))))))) + +(define* (validate-link-list list #:optional + (valid? default-val-validator)) + (list-of? list + (lambda (elt) + (and (uri-reference? (car elt)) + (key-value-list? (cdr elt) valid?))))) + +(define* (write-link-list list port #:optional + (val-writer default-val-writer)) + (put-list + port list + (lambda (port item) + (put-string port "<") + ;; write-uri would discard the fragment. + (put-string port (uri->string (car item))) + (put-string port ">") + (unless (null? (cdr item)) + (put-string port " ") + (write-key-value-list item port val-writer ";"))) + ",")) + (define-syntax string-match? (lambda (x) (syntax-case x () @@ -1285,6 +1350,16 @@ treated specially, and is just returned as a plain string." (lambda (val) (validate-param-list val val-validator)) (lambda (val port) (write-param-list val port val-writer)))) +;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1) +(define* (declare-link-list-header! name #:optional + (val-parser default-val-parser) + (val-validator default-val-validator) + (val-writer default-val-writer)) + (declare-header! name + (lambda (str) (parse-link-list str val-parser)) + (lambda (val) (validate-link-list val val-validator)) + (lambda (val port) (write-link-list val port val-writer)))) + ;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1) (define* (declare-key-value-list-header! name #:optional (val-parser default-val-parser) @@ -1796,6 +1871,9 @@ treated specially, and is just returned as a plain string." ;; (declare-date-header! "If-Unmodified-Since") +;; Link = *( link-value ) +(declare-link-list-header! "Link") + ;; Max-Forwards = 1*DIGIT ;; (declare-integer-header! "Max-Forwards") @@ -1894,6 +1972,8 @@ treated specially, and is just returned as a plain string." (lambda (val port) (put-entity-tag port val))) +;; Link: See request headers. + ;; Location = URI-reference ;; ;; In RFC 2616, Location was specified as being an absolute URI. This diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 06dd9479c..301a91e5e 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -289,7 +289,41 @@ "123 foo \"core breach imminent\" \"Tue, 15 Nov 1994 08:12:31 GMT\"" `((123 "foo" "core breach imminent" ,(string->date "Tue, 15 Nov 1994 08:12:31 +0000" - "~a, ~d ~b ~Y ~H:~M:~S ~z"))))) + "~a, ~d ~b ~Y ~H:~M:~S ~z")))) + (pass-if-parse + link + "<>" + (list (cons (build-relative-ref) '()))) + (pass-if-parse + link + "<./something>" + (list (cons (build-relative-ref #:path "./something") '()))) + (pass-if-parse + link + "<./something>; key=\"value,<>;fake=value\"" + (list (cons (build-relative-ref #:path "./something") + '((key . "<>;fake=value"))))) + (pass-if-parse + link + "<./something>; key=\"value,<>; fake=value\", <>; a=b; c=d" + (list (cons (build-relative-ref #:path "./something") + '((key . "<>; fake=value"))) + (cons (build-relative-ref) + '((a . "b") (c . "d"))))) + (pass-if-parse + link + "; rel=\"previous\"; title=\"previous chapter\"" + (list (cons (build-uri 'http + #:host "example.com" + #:path "/TheBook/chapter2") + '((rel . "previous") + (title . "previous chapter"))))) + (pass-if-parse + link + "; rel=\"http://example.net/foo\"; bar=baz" + (list (cons (build-relative-ref #:path "/") + '((rel . "http://example.net/foo") + (bar . "baz")))))) (with-test-prefix "entity headers" (pass-if-parse allow "foo, bar" '(foo bar)) -- 2.41.0