* [PATCH v2 1/4] Add resolve-relative-reference in (web uri), as in RFC 3986 5.2.
2023-10-28 10:42 [PATCH v2 0/4] Add the HTTP Link header (fixed) Vivien Kraus
@ 2023-09-25 16:48 ` Vivien Kraus
2023-10-28 8:51 ` [PATCH v2 4/4] Parse the HTTP Link header Vivien Kraus
` (2 subsequent siblings)
3 siblings, 0 replies; 5+ messages in thread
From: Vivien Kraus @ 2023-09-25 16:48 UTC (permalink / raw)
To: guile-devel
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain, Size: 17963 bytes --]
* module/web/uri.scm (remove-dot-segments): Implement algorithm 5.2.4.
(merge-paths): Implement algorithm 5.2.3.
(resolve-relative-reference): Implement algorithm 5.2.2.
(module): Export resolve-relative-reference.
* NEWS: Reference it here.
* doc/ref/web.texi (URIs): Document it here.
(Subtypes of URI): Add a @node declaration to cross-reference it.
(HTTP Headers) [location]: Point to the section for different URI types.
(Web Client) [http-request]: Indicate that no redirection is performed,
and warn about blindly following them.
* AUTHORS: Mention me.
* THANKS: Thank me.
---
AUTHORS | 8 ++
NEWS | 7 ++
THANKS | 1 +
doc/ref/web.texi | 41 ++++++++-
module/web/uri.scm | 161 +++++++++++++++++++++++++++++++++-
test-suite/tests/web-uri.test | 67 ++++++++++++++
6 files changed, 283 insertions(+), 2 deletions(-)
diff --git a/AUTHORS b/AUTHORS
index d756a74ce..2a95d3b0b 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -370,3 +370,11 @@ John W. Eaton, based on code from AT&T Bell Laboratories and Bellcore:
Gregory Marton:
In the subdirectory test-suite/tests, changes to:
hash.test
+
+Vivien Kraus:
+In the subdirectory module/web, changes to:
+ uri.scm
+In the subdirectory doc/ref, changes to:
+ web.texi
+In the subdirectory test-suite/tests, changes to:
+ web-uri.test
diff --git a/NEWS b/NEWS
index b319404d7..bdf75cb3c 100644
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,13 @@ Changes in 3.0.10 (since 3.0.9)
* New interfaces and functionality
+** New function in (web uri): resolve-relative-reference
+
+Implement the /5.2. Relative Resolution/ algorithm in RFC 3986. It may
+be used to request a moved resource in case of a 301 or 302 HTTP
+response, by resolving the Location value of the response on top of the
+requested URI.
+
** New warning: unused-module
This analysis, enabled at `-W2', issues warnings for modules that appear
diff --git a/THANKS b/THANKS
index aa4877e95..a1f982f04 100644
--- a/THANKS
+++ b/THANKS
@@ -19,6 +19,7 @@ Contributors since the last release:
Chris K Jester-Young
David Kastrup
Daniel Kraft
+ Vivien Kraus
Daniel Krueger
Noah Lavine
Christopher Lemmer Webber
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 607c855b6..d92a8d51a 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -297,6 +297,7 @@ For example, the list @code{("scrambled eggs" "biscuits&gravy")} encodes
as @code{"scrambled%20eggs/biscuits%26gravy"}.
@end deffn
+@node Subtypes of URI
@subsubheading Subtypes of URI
As we noted above, not all URI objects have a scheme. You might have
@@ -356,6 +357,32 @@ Parse @var{string} into a URI object, while asserting that no scheme is
present. Return @code{#f} if the string could not be parsed.
@end deffn
+@cindex resolve URI reference
+In order to get a URI object from a base URI and a relative reference,
+one has to use a @dfn{relative URI reference resolution} algorithm. For
+instance, given a base URI, @samp{https://example.com/over/here}, and a
+relative reference, @samp{../no/there}, it may seem easy to get an
+absolute URI as @samp{https://example.com/over/../no/there}. It is
+possible that the server at @samp{https://example.com} could serve the
+same resource under this URL as
+@samp{https://example.com/no/there}. However, a web cache, or a linked
+data processor, must understand that the relative reference resolution
+leads to @samp{https://example.com/no/there}.
+
+@deffn {Scheme procedure} resolve-relative-reference @var{base} @var{relative}
+Return a URI object representing @var{relative}, using the components of
+@var{base} if missing, as defined in section 5.2 in RFC 3986. Both
+@var{base} and @var{relative} may be full URI or relative URI
+references. The name ``relative'' indicates the argument’s relationship
+to @var{base}, not its type. This function cannot return a relative
+reference (it can only return an absolute URI object), if either
+@var{base} or @var{relative} is an absolute URI object.
+
+Please note that any part of @var{base} may be overriden by
+@var{relative}. For instance, if @var{base} has a @code{https} URI
+scheme, and if @var{relative} has a @code{http} scheme, then the result
+will have a @code{http} scheme.
+@end deffn
@node HTTP
@subsection The Hyper-Text Transfer Protocol
@@ -1038,7 +1065,8 @@ The entity-tag of the resource.
@deftypevr {HTTP Header} URI-reference location
A URI reference on which a request may be completed. Used in
combination with a redirecting status code to perform client-side
-redirection.
+redirection. @xref{Subtypes of URI, the distinction between types of
+URI}, for more information on relative references.
@example
(parse-header 'location "http://example.com/other")
@result{} #<uri ...>
@@ -1501,6 +1529,17 @@ constants, such as @code{certificate-status/signer-not-found} or
Connect to the server corresponding to @var{uri} and make a request over
HTTP, using @var{method} (@code{GET}, @code{HEAD}, @code{POST}, etc.).
+@code{http-request} does not follow redirections. If a redirection is
+required, @code{http-request} returns a response object with an adequate
+response code (e.g. 301 or 302).
+
+Making web requests on a network where private servers are hosted comes
+with potential security risks. A malicious public server might forge
+its DNS record to point to your internal address. It might also
+redirect you to your internal server. In the first case, or if you
+follow the redirection of the second case, then you may accidentally
+connect to your private server as if it were public.
+
The following keyword arguments allow you to modify the requests in
various ways, for example attaching a body to the request, or setting
specific headers. The following table lists the keyword arguments and
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 8e0b9bee7..319010097 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -1,6 +1,7 @@
;;;; (web uri) --- URI manipulation tools
;;;;
;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014,2019-2021 Free Software Foundation, Inc.
+;;;; Copyright (C) 2023 Vivien Kraus
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -47,7 +48,9 @@
uri-reference? relative-ref?
build-uri-reference build-relative-ref
- string->uri-reference string->relative-ref))
+ string->uri-reference string->relative-ref
+
+ resolve-relative-reference))
(define-record-type <uri>
(make-uri scheme userinfo host port path query fragment)
@@ -501,3 +504,159 @@ strings, and join the parts together with ‘/’ as a delimiter.
For example, the list ‘(\"scrambled eggs\" \"biscuits&gravy\")’
encodes as ‘\"scrambled%20eggs/biscuits%26gravy\"’."
(string-join (map uri-encode parts) "/"))
+
+(define (remove-dot-segments path)
+ "Remove the @samp{./} and @samp{../} segments in @var{path}, as
+ RFC3986, section 5.2.4."
+ (let scan ((input
+ (let ((components (split-and-decode-uri-path path)))
+ (if (string-suffix? "/" path)
+ `(,@components "")
+ components)))
+ (input-path-absolute? (string-prefix? "/" path))
+ (output '())
+ (output-absolute? #f)
+ (output-ends-in-/? (string-suffix? "/" path)))
+ (cond
+ ((and input-path-absolute?
+ (null? input))
+ ;; Transfer the initial "/" from the input to the end of the
+ ;; output.
+ (scan '() #f output output-absolute? #t))
+ ((null? input)
+ (string-append
+ (if output-absolute? "/" "")
+ (encode-and-join-uri-path
+ (reverse output))
+ (if output-ends-in-/? "/" "")))
+ ((and (not input-path-absolute?)
+ (or (equal? (car input) "..")
+ (equal? (car input) ".")))
+ (scan (cdr input) #f output output-absolute? output-ends-in-/?))
+ ((and input-path-absolute?
+ (equal? (car input) "."))
+ (scan (cdr input) #t output output-absolute? output-ends-in-/?))
+ ((and input-path-absolute?
+ (equal? (car input) ".."))
+ (scan (cdr input) #t
+ (if (null? output)
+ output
+ (cdr output))
+ ;; Remove the last segment, including the preceding /. So,
+ ;; if there is 0 or 1 segment, remove the root / too.
+ (if (or (null? output) (null? (cdr output)))
+ #f ;; remove the /
+ #t) ;; keep it
+ #f))
+ (else
+ (scan (cdr input)
+ ;; If there is only 1 item in input, then it does not end in
+ ;; /, so the recursive call does not start with
+ ;; /. Otherwise, the recursive call starts with /.
+ (not (null? (cdr input)))
+ (cons (car input) output)
+ ;; If the output is empty and the input path is absolute,
+ ;; the / of the transferred path is transferred as well.
+ (or output-absolute?
+ (and (null? output)
+ input-path-absolute?))
+ #f)))))
+
+(define (merge-paths base-has-authority? base relative)
+ "Return @samp{@var{base}/@var{relative}}, with the subtleties of
+absolute paths explained in RFC3986, section 5.2.3. If the base URI has
+an authority (userinfo, host, port), then the processing is a bit
+different."
+ (if (and base-has-authority?
+ (equal? base ""))
+ (string-append "/" relative)
+ (let ((last-/ (string-rindex base #\/)))
+ (if last-/
+ (string-append (substring base 0 last-/) "/" relative)
+ relative))))
+
+(define (resolve-relative-reference base relative)
+ "Resolve @var{relative} on top of @var{base}, as RFC3986, section
+5.2. Both @var{relative} and @var{base} may be URI or relative
+references. The name ``relative'' indicates the argument’s relationship
+to @var{base}, not its type. Both @var{base} and @var{relative} may be
+full URIs or relative references. The return value is a URI if either
+@var{relative} or @var{base} is a URI."
+ (let ((b-scheme (uri-scheme base))
+ (b-userinfo (uri-userinfo base))
+ (b-host (uri-host base))
+ (b-port (uri-port base))
+ (b-path (uri-path base))
+ (b-query (uri-query base))
+ (b-fragment (uri-fragment base))
+ (r-scheme (uri-scheme relative))
+ (r-userinfo (uri-userinfo relative))
+ (r-host (uri-host relative))
+ (r-port (uri-port relative))
+ (r-path (uri-path relative))
+ (r-query (uri-query relative))
+ (r-fragment (uri-fragment relative))
+ (t-scheme #f)
+ (t-userinfo #f)
+ (t-host #f)
+ (t-port #f)
+ (t-path "")
+ (t-query #f)
+ (t-fragment #f))
+ ;; https://www.rfc-editor.org/rfc/rfc3986#section-5.2
+
+ ;;The programming style uses mutations to better adhere to the
+ ;;algorithm specification.
+ (if r-scheme
+ (begin
+ (set! t-scheme r-scheme)
+ (set! t-userinfo r-userinfo)
+ (set! t-host r-host)
+ (set! t-port r-port)
+ (set! t-path (remove-dot-segments r-path))
+ (set! t-query r-query))
+ ;; r-scheme is not defined:
+ (begin
+ (if r-host
+ (begin
+ (set! t-userinfo r-userinfo)
+ (set! t-host r-host)
+ (set! t-port r-port)
+ (set! t-path (remove-dot-segments r-path))
+ (set! t-query r-query))
+ ;; r-scheme is not defined, r-authority is not defined:
+ (begin
+ (if (equal? r-path "")
+ (begin
+ (set! t-path b-path)
+ (if r-query
+ ;; r-scheme, r-authority, r-path are not
+ ;; defined:
+ (set! t-query r-query)
+ ;; r-scheme, r-authority, r-path, r-query are
+ ;; not defined:
+ (set! t-query b-query)))
+ ;; r-scheme, r-authority not defined, r-path defined:
+ (begin
+ (if (string-prefix? "/" r-path)
+ ;; r-scheme, r-authority not defined, r-path
+ ;; absolute:
+ (set! t-path (remove-dot-segments r-path))
+ ;; r-scheme, r-authority not defined, r-path
+ ;; relative:
+ (set! t-path
+ (remove-dot-segments
+ (merge-paths b-host b-path r-path))))
+ (set! t-query r-query)))
+ (set! t-userinfo b-userinfo)
+ (set! t-host b-host)
+ (set! t-port b-port)))
+ (set! t-scheme b-scheme)))
+ (set! t-fragment r-fragment)
+ (build-uri-reference #:scheme t-scheme
+ #:userinfo t-userinfo
+ #:host t-host
+ #:port t-port
+ #:path t-path
+ #:query t-query
+ #:fragment t-fragment)))
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 95fd82f16..cdd0dc7b6 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -20,6 +20,7 @@
(define-module (test-web-uri)
#:use-module (web uri)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 string-fun)
#:use-module (test-suite lib))
@@ -693,3 +694,69 @@
(pass-if (equal? "foo%20bar" (uri-encode "foo bar")))
(pass-if (equal? "foo%0A%00bar" (uri-encode "foo\n\x00bar")))
(pass-if (equal? "%3C%3E%5C%5E" (uri-encode "<>\\^"))))
+
+(with-test-prefix "resolve relative reference"
+ ;; Test suite in RFC3986, section 5.4.
+ (let ((base (string->uri "http://a/b/c/d;p?q"))
+ (equal/encoded?
+ ;; The test suite checks for ';' characters, but Guile escapes
+ ;; them in URIs. Same for '='.
+ (let ((escape-colon
+ (lambda (x)
+ (string-replace-substring x ";" "%3B")))
+ (escape-equal
+ (lambda (x)
+ (string-replace-substring x "=" "%3D"))))
+ (lambda (x y)
+ (equal? (escape-colon (escape-equal x))
+ (escape-colon (escape-equal y)))))))
+ (let ((resolve
+ (lambda (relative)
+ (let* ((relative-uri
+ (string->uri-reference relative))
+ (resolved-uri
+ (resolve-relative-reference base relative-uri))
+ (resolved (uri->string resolved-uri)))
+ resolved))))
+ (with-test-prefix "normal"
+ (pass-if (equal/encoded? (resolve "g:h") "g:h"))
+ (pass-if (equal/encoded? (resolve "g") "http://a/b/c/g"))
+ (pass-if (equal/encoded? (resolve "./g") "http://a/b/c/g"))
+ (pass-if (equal/encoded? (resolve "g/") "http://a/b/c/g/"))
+ (pass-if (equal/encoded? (resolve "/g") "http://a/g"))
+ (pass-if (equal/encoded? (resolve "//g") "http://g"))
+ (pass-if (equal/encoded? (resolve "?y") "http://a/b/c/d;p?y"))
+ (pass-if (equal/encoded? (resolve "g?y") "http://a/b/c/g?y"))
+ (pass-if (equal/encoded? (resolve "#s") "http://a/b/c/d;p?q#s"))
+ (pass-if (equal/encoded? (resolve "g?y#s") "http://a/b/c/g?y#s"))
+ (pass-if (equal/encoded? (resolve ";x") "http://a/b/c/;x"))
+ (pass-if (equal/encoded? (resolve "g;x?y#s") "http://a/b/c/g;x?y#s"))
+ (pass-if (equal/encoded? (resolve "") "http://a/b/c/d;p?q"))
+ (pass-if (equal/encoded? (resolve ".") "http://a/b/c/"))
+ (pass-if (equal/encoded? (resolve "./") "http://a/b/c/"))
+ (pass-if (equal/encoded? (resolve "..") "http://a/b/"))
+ (pass-if (equal/encoded? (resolve "../") "http://a/b/"))
+ (pass-if (equal/encoded? (resolve "../g") "http://a/b/g"))
+ (pass-if (equal/encoded? (resolve "../..") "http://a/"))
+ (pass-if (equal/encoded? (resolve "../../") "http://a/"))
+ (pass-if (equal/encoded? (resolve "../../g") "http://a/g")))
+ (with-test-prefix "abnormal"
+ (pass-if (equal/encoded? (resolve "../../../g") "http://a/g"))
+ (pass-if (equal/encoded? (resolve "../../../../g") "http://a/g"))
+ (pass-if (equal/encoded? (resolve "/./g") "http://a/g"))
+ (pass-if (equal/encoded? (resolve "/../g") "http://a/g"))
+ (pass-if (equal/encoded? (resolve "g.") "http://a/b/c/g."))
+ (pass-if (equal/encoded? (resolve ".g") "http://a/b/c/.g"))
+ (pass-if (equal/encoded? (resolve "g..") "http://a/b/c/g.."))
+ (pass-if (equal/encoded? (resolve "..g") "http://a/b/c/..g"))
+ (pass-if (equal/encoded? (resolve "./../g") "http://a/b/g"))
+ (pass-if (equal/encoded? (resolve "./g/.") "http://a/b/c/g/"))
+ (pass-if (equal/encoded? (resolve "g/./h") "http://a/b/c/g/h"))
+ (pass-if (equal/encoded? (resolve "g/../h") "http://a/b/c/h"))
+ (pass-if (equal/encoded? (resolve "g;x=1/./y") "http://a/b/c/g;x=1/y"))
+ (pass-if (equal/encoded? (resolve "g;x=1/../y") "http://a/b/c/y"))
+ (pass-if (equal/encoded? (resolve "g?y/./x") "http://a/b/c/g?y/./x"))
+ (pass-if (equal/encoded? (resolve "g?y/../x") "http://a/b/c/g?y/../x"))
+ (pass-if (equal/encoded? (resolve "g#s/./x") "http://a/b/c/g#s/./x"))
+ (pass-if (equal/encoded? (resolve "g#s/../x") "http://a/b/c/g#s/../x"))
+ (pass-if (equal/encoded? (resolve "http:g") "http:g"))))))
--
2.41.0
^ permalink raw reply related [flat|nested] 5+ messages in thread* [PATCH v2 4/4] Parse the HTTP Link header.
2023-10-28 10:42 [PATCH v2 0/4] Add the HTTP Link header (fixed) Vivien Kraus
2023-09-25 16:48 ` [PATCH v2 1/4] Add resolve-relative-reference in (web uri), as in RFC 3986 5.2 Vivien Kraus
@ 2023-10-28 8:51 ` Vivien Kraus
2023-10-28 8:57 ` [PATCH v2 2/4] Update section comment in (web http) Vivien Kraus
2023-10-28 10:20 ` [PATCH v2 3/4] Check that key/value parameters in HTTP headers are quoted in needed Vivien Kraus
3 siblings, 0 replies; 5+ messages in thread
From: Vivien Kraus @ 2023-10-28 8:51 UTC (permalink / raw)
To: guile-devel
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain, Size: 9695 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 | 93 ++++++++++++++++++++++++++++++++++
test-suite/tests/web-http.test | 36 ++++++++++++-
5 files changed, 152 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 195265dfd..9f256c21e 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -638,6 +638,84 @@ 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 #\< start) 1)))
+ (if uriref-start
+ (let* ((close-delim
+ (string-index str #\> uriref-start))
+ (uriref-stop
+ (or close-delim end))
+ (param-start
+ (skip-whitespace
+ str
+ (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)))
+ (when (and (< param-start end)
+ (not (eqv? (string-ref str param-start) #\;)))
+ (bad-header-component
+ 'param-list
+ (substring str param-start end)))
+ (let ((first-param-start
+ (skip-whitespace
+ str
+ (+ param-start 1))))
+ ;; Skip the first semicolon.
+ (call-with-values
+ (lambda ()
+ (parse-param-component str val-parser first-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 i 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 (cdr item) port val-writer ";")))
+ ","))
+
(define-syntax string-match?
(lambda (x)
(syntax-case x ()
@@ -1286,6 +1364,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)
@@ -1797,6 +1885,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")
@@ -1895,6 +1986,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 b73d72ced..5d5728897 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 . "value,<>;fake=value")))))
+ (pass-if-parse
+ link
+ "<./something>; key=\"value,<>; fake=value\", <>; a=b; c=d"
+ (list (cons (build-relative-ref #:path "./something")
+ '((key . "value,<>; 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
^ permalink raw reply related [flat|nested] 5+ messages in thread