From: Vivien Kraus <vivien@planete-kraus.eu>
To: guile-devel@gnu.org
Cc: Maxime Devos <maximedevos@telenet.be>
Subject: [PATCH 3/3] Parse the HTTP Link header.
Date: Sat, 28 Oct 2023 10:51:48 +0200 [thread overview]
Message-ID: <091279a8616d296a32a87074cf6450a04766f838.1698483663.git.vivien@planete-kraus.eu> (raw)
In-Reply-To: <cover.1698483663.git.vivien@planete-kraus.eu>
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain, Size: 9191 bytes --]
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{} (#<relative-ref path="/"> (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
+ "<http://example.com/TheBook/chapter2>; 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
next prev parent reply other threads:[~2023-10-28 8:51 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-10-28 9:01 [PATCH 0/3] Parse the Link header Vivien Kraus
2023-09-25 16:48 ` [PATCH 1/3] Add resolve-relative-reference in (web uri), as in RFC 3986 5.2 Vivien Kraus
2023-10-28 8:51 ` Vivien Kraus [this message]
2023-10-28 8:57 ` [PATCH 2/3] Update section comment in (web http) Vivien Kraus
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=091279a8616d296a32a87074cf6450a04766f838.1698483663.git.vivien@planete-kraus.eu \
--to=vivien@planete-kraus.eu \
--cc=guile-devel@gnu.org \
--cc=maximedevos@telenet.be \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).