[PATCH 3/3] Parse the HTTP Link header.

[Vivien Kraus]

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