HTTP Link header: use GOOPS and document it

11 files changed, 683 insertions, 181 deletions

diff --git a/doc/disfluid.texi b/doc/disfluid.texi
index 011f3f9..be32b85 100644
--- a/doc/disfluid.texi
+++ b/doc/disfluid.texi
@@ -71,6 +71,7 @@ A PDF version of this manual is available at
 * Client manifest::
 * The Json Web Token::
 * Caching on server side::
+* The HTTP Link header::
 * Content negociation::
 * Running an Identity Provider::
 * Running a Resource Server::
@@ -1401,6 +1402,71 @@ This parameters sets the cache directory. By default, it is
 @emph{XDG_CACHE_HOME}.
 @end deffn
 
+@node The HTTP Link header
+@chapter The HTTP Link header
+The HTTP Link header lets you attach metadata about a resource,
+directly in the HTTP protocol. It is used to link resources to their
+auxiliary resources, for instance.
+
+The following API is defined in @emph{(webid-oidc http-link)}:
+
+@deftp {Class} <link> @var{target-iri} @var{relation-type} @var{target-attributes}
+The link refers to the @var{target-iri} that is being linked to the
+requested resource, with a given @var{relation-type} (a string), and
+optional additional @var{target-attributes}.
+
+When constructing a <link>, you should use the
+@code{#:@var{target-iri}}, @code{#:@var{relation-type}} and
+@code{#:@var{target-attributes}} keyword arguments
+(@code{#:@var{target-attributes}} defaults to the empty list) to
+initialize the link. For convenience, the @code{#:@var{anchor}},
+@code{#:@var{hreflang}}, @code{#:@var{media}}, @code{#:@var{title}},
+@code{#:@var{title*}} and @code{#:@var{type}} keyword arguments can be
+passed to add well-known target attributes.
+@end deftp
+
+@deftp {Class} <target-attribute> @var{key} @var{value}
+If you wish to add new extension target attributes, you can create an
+ad-hoc target attribute with @var{key} and @var{value} (initialized as
+@code{#:@var{key}} and @code{#:@var{value}} constructor keyword
+arguments).
+@end deftp
+
+@deffn {Generic} target-iri @var{link}
+@deffnx {Generic} relation-type @var{link}
+@deffnx {Generic} target-attributes @var{link}
+Getters for the @code{<link>} class.
+@end deffn
+
+@deffn {Generic} key @var{target-attribute}
+@deffnx {Generic} value @var{target-attribute}
+Getters for the @code{<target-attribute>} class.
+@end deffn
+
+@deffn {Generic} target-attribute @var{link} @var{key}
+Return the value of the first target attributet with @var{key}.
+@end deffn
+
+@deffn {Generic} anchor @var{link}
+@deffnx {Generic} hreflang @var{link}
+@deffnx {Generic} media @var{link}
+@deffnx {Generic} title @var{link}
+@deffnx {Generic} title* @var{link}
+@deffnx {Generic} type @var{link}
+Convenience attribute lookup functions. @code{anchor} returns an URI
+referencce, the others return a string.
+@end deffn
+
+@deffn {function} declare-link-header!
+Declare functions to parse, validate and print HTTP Link headers with
+the Guile web request / response API.
+@end deffn
+
+@deffn {function} request-links @var{request}
+@deffnx {function} response-links @var{response}
+Return the list of links in @var{request} or @var{response}.
+@end deffn
+
 @node Content negociation
 @chapter Content negociation
 There are a number of different available syntaxes for RDF, some being
diff --git a/po/disfluid.pot b/po/disfluid.pot
index 5e6e2e9..1c36a1d 100644
--- a/po/disfluid.pot
+++ b/po/disfluid.pot
@@ -8,7 +8,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: disfluid SNAPSHOT\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-10-07 12:28+0200\n"
+"POT-Creation-Date: 2021-10-11 16:45+0200\n"
 "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
 "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
 "Language-Team: LANGUAGE <LL@li.org>\n"
@@ -1052,6 +1052,50 @@ msgstr ""
 msgid "<p>You can only use the <emph>GET</emph> method on this resource.</p>"
 msgstr ""
 
+#: src/scm/webid-oidc/http-link.scm:148
+msgid "the #:anchor parameter should be a string or an URI reference"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:159
+msgid "the #:hreflang parameter should be a string"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:170
+msgid "the #:media parameter should be a string"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:181
+msgid "the #:title parameter should be a string"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:192
+msgid "the #:title* parameter should be a string"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:203
+msgid "the #:type parameter should be a string"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:208
+msgid "#:target-iri and #:relation-type are required"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:216
+msgid "#:target-iri should be an URI reference"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:221
+msgid "#:relation-type should be a string"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:242
+msgid "the #:attribute-key parameter should be a string or symbol"
+msgstr ""
+
+#: src/scm/webid-oidc/http-link.scm:247
+msgid "the #:attribute-value parameter should be a string or URI"
+msgstr ""
+
 #: src/scm/webid-oidc/identity-provider.scm:74
 msgid "Warning: generating a new key pair."
 msgstr ""
diff --git a/po/fr.po b/po/fr.po
index e0fefe9..c99f37f 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -2,8 +2,8 @@ msgid ""
 msgstr ""
 "Project-Id-Version: webid-oidc 0.0.0\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-10-07 12:28+0200\n"
-"PO-Revision-Date: 2021-10-05 22:56+0200\n"
+"POT-Creation-Date: 2021-10-11 16:45+0200\n"
+"PO-Revision-Date: 2021-10-11 16:45+0200\n"
 "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n"
 "Language-Team: French <vivien@planete-kraus.eu>\n"
 "Language: fr\n"
@@ -1157,6 +1157,54 @@ msgstr ""
 "<p>Vous pouvez uniquement utiliser la méthode <emph>GET</emph> pour cette "
 "ressource.</p>"
 
+#: src/scm/webid-oidc/http-link.scm:148
+msgid "the #:anchor parameter should be a string or an URI reference"
+msgstr ""
+"le paramètre #:anchor doit être une chaîne de caractères ou une référence "
+"d’URI"
+
+#: src/scm/webid-oidc/http-link.scm:159
+msgid "the #:hreflang parameter should be a string"
+msgstr "le paramètre #:hreflang doit être une chaîne de caractères"
+
+#: src/scm/webid-oidc/http-link.scm:170
+msgid "the #:media parameter should be a string"
+msgstr "le paramètre #:media doit être une chaîne de caractères"
+
+#: src/scm/webid-oidc/http-link.scm:181
+msgid "the #:title parameter should be a string"
+msgstr "le paramètre #:title doit être une chaîne de caractères"
+
+#: src/scm/webid-oidc/http-link.scm:192
+msgid "the #:title* parameter should be a string"
+msgstr "le paramètre title* doit être une chaîne de caractères"
+
+#: src/scm/webid-oidc/http-link.scm:203
+msgid "the #:type parameter should be a string"
+msgstr "le paramètre #:type doit être une chaîne de caractères"
+
+#: src/scm/webid-oidc/http-link.scm:208
+msgid "#:target-iri and #:relation-type are required"
+msgstr "#:target-iri et #:relation-type sont requis"
+
+#: src/scm/webid-oidc/http-link.scm:216
+msgid "#:target-iri should be an URI reference"
+msgstr "#:target-iri doit être une référence d’IRI"
+
+#: src/scm/webid-oidc/http-link.scm:221
+msgid "#:relation-type should be a string"
+msgstr "#:relation-type doit être une chaîne de caractères"
+
+#: src/scm/webid-oidc/http-link.scm:242
+msgid "the #:attribute-key parameter should be a string or symbol"
+msgstr ""
+"le paramètre #:attribute-key doit être une chaîne de caractères ou un symbole"
+
+#: src/scm/webid-oidc/http-link.scm:247
+msgid "the #:attribute-value parameter should be a string or URI"
+msgstr ""
+"le paramètre #:attribute-value doit être une chaîne de caractères ou une URI"
+
 #: src/scm/webid-oidc/identity-provider.scm:74
 msgid "Warning: generating a new key pair."
 msgstr "Attention : génération d'une nouvelle paire de clé."
@@ -2751,15 +2799,11 @@ msgstr "Paramètres"
 #~ msgid "the client manifest should be a JSON object"
 #~ msgstr "le manifeste client doit être un objet JSON"
 
-#, fuzzy, scheme-format
-#~| msgid "cannot fetch a client manifest: ~a"
 #~ msgid "cannot fetch the client manifest ~s: ~a"
-#~ msgstr "impossible de télécharger un manifeste client : ~a"
+#~ msgstr "impossible de télécharger le manifeste client ~s : ~a"
 
-#, fuzzy, scheme-format
-#~| msgid "cannot fetch a client manifest: ~a"
 #~ msgid "cannot fetch the client manifest ~s"
-#~ msgstr "impossible de télécharger un manifeste client : ~a"
+#~ msgstr "impossible de télécharger le manifeste client ~s"
 
 #, scheme-format
 #~ msgid ""
diff --git a/src/scm/webid-oidc/http-link.scm b/src/scm/webid-oidc/http-link.scm
index f8a239a..80b4109 100644
--- a/src/scm/webid-oidc/http-link.scm
+++ b/src/scm/webid-oidc/http-link.scm
@@ -19,20 +19,235 @@
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 peg)
   #:use-module (ice-9 atomic)
+  #:use-module (ice-9 match)
   #:use-module (web uri)
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web http)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module (oop goops)
   #:declarative? #t
   #:export
   (
 
+   <link>
+   target-iri ;; context-iri is not remembered because it does not
+              ;; only depend on the header values
+   relation-type
+   target-attributes
+   <target-attribute>
+   attribute-key
+   attribute-value
+
+   anchor
+   hreflang
+   media
+   title
+   title*
+   type
+   target-attribute
+
    declare-link-header!
    request-links
    response-links
 
    ))
 
+(define-class <link> ()
+  (target-iri #:init-keyword #:target-iri #:getter target-iri)
+  (relation-type #:init-keyword #:relation-type #:getter relation-type)
+  (target-attributes #:init-keyword #:target-attributes #:getter target-attributes))
+
+(define-method (equal? (x <link>) (y <link>))
+  (and (equal? (target-iri x) (target-iri y))
+       (equal? (relation-type x) (relation-type y))
+       (equal? (target-attributes x) (target-attributes y))))
+
+(define-method (write (link <link>) port)
+  (format port "#<<link> target-iri=~s; relation-type=~s; target-attributes=~s>"
+          (uri->string (target-iri link))
+          (relation-type link)
+          (target-attributes link)))
+
+(define-method (display (link <link>) port)
+  (format port "#<<link> target-iri=~a; relation-type=~a; target-attributes=~a>"
+          (uri->string (target-iri link))
+          (relation-type link)
+          (target-attributes link)))
+
+(define-class <target-attribute> ()
+  (attribute-key #:init-keyword #:attribute-key #:getter attribute-key)
+  (attribute-value #:init-keyword #:attribute-value #:getter attribute-value))
+
+(define-method (equal? (x <target-attribute>) (y <target-attribute>))
+  (and (equal? (attribute-key x) (attribute-key y))
+       (equal? (attribute-value x) (attribute-value y))))
+
+(define-method (write (target-attribute <target-attribute>) port)
+  (format port "#<<target-attribute> attribute-key=~s; attribute-value=~s>"
+          (attribute-key target-attribute)
+          (attribute-value target-attribute)))
+
+(define-method (display (target-attribute <target-attribute>) port)
+  (format port "#<<target-attribute> attribute-key=~a; attribute-value=~a>"
+          (attribute-key target-attribute)
+          (attribute-value target-attribute)))
+
+(define-method (target-attribute (link <link>) key)
+  (when (string? key)
+    (set! key (string->symbol key)))
+  (assq-ref
+   (map (lambda (attribute)
+          `(,(attribute-key attribute) . ,(attribute-value attribute)))
+        (target-attributes link))
+   key))
+
+(define-method (anchor (link <link>))
+  (string->uri-reference 
+   (target-attribute link 'anchor)))
+
+(define-method (hreflang (link <link>))
+  (target-attribute link 'anchor))
+
+(define-method (media (link <link>))
+  (target-attribute link 'media))
+
+(define-method (title (link <link>))
+  (target-attribute link 'title))
+
+(define-method (title* (link <link>))
+  (target-attribute link 'title*))
+
+(define-method (type (link <link>))
+  (target-attribute link 'type))
+
+(define-method (initialize (link <link>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((target-iri #f)
+    (relation-type #f)
+    (target-attributes '())
+    (anchor #f)
+    (hreflang #f)
+    (media #f)
+    (title #f)
+    (title* #f)
+    (type #f))
+   (let ((extra-target-attributes
+          (append
+           (match anchor
+             ((or (? uri-reference? anchor)
+                  (? string? (= string->uri-reference (? uri-reference? anchor))))
+              (list (make <target-attribute>
+                      #:attribute-key 'anchor
+                      #:attribute-value (uri->string anchor))))
+             ((? not anchor) '())
+             (otherwise
+              (scm-error 'wrong-type-arg "make <link>"
+                         (G_ "the #:anchor parameter should be a string or an URI reference")
+                         '()
+                         (list anchor))))
+           (match hreflang
+             ((? string? hreflang)
+              (list (make <target-attribute>
+                      #:attribute-key 'hreflang
+                      #:attribute-value hreflang)))
+             ((? not hreflang) '())
+             (otherwise
+              (scm-error 'wrong-type-arg "make <link>"
+                         (G_ "the #:hreflang parameter should be a string")
+                         '()
+                         (list hreflang))))
+           (match media
+             ((? string? media)
+              (list (make <target-attribute>
+                      #:attribute-key 'media
+                      #:attribute-value media)))
+             ((? not media) '())
+             (otherwise
+              (scm-error 'wrong-type-arg "make <link>"
+                         (G_ "the #:media parameter should be a string")
+                         '()
+                         (list media))))
+           (match title
+             ((? string? title)
+              (list (make <target-attribute>
+                      #:attribute-key 'title
+                      #:attribute-value title)))
+             ((? not title) '())
+             (otherwise
+              (scm-error 'wrong-type-arg "make <link>"
+                         (G_ "the #:title parameter should be a string")
+                         '()
+                         (list title))))
+           (match title*
+             ((? string? title*)
+              (list (make <target-attribute>
+                      #:attribute-key 'title*
+                      #:attribute-value title*)))
+             ((? not title*) '())
+             (otherwise
+              (scm-error 'wrong-type-arg "make <link>"
+                         (G_ "the #:title* parameter should be a string")
+                         '()
+                         (list title*))))
+           (match type
+             ((? string? type)
+              (list (make <target-attribute>
+                      #:attribute-key 'type
+                      #:attribute-value type)))
+             ((? not type) '())
+             (otherwise
+              (scm-error 'wrong-type-arg "make <link>"
+                         (G_ "the #:type parameter should be a string")
+                         '()
+                         (list type)))))))
+     (unless (and target-iri relation-type)
+       (scm-error 'wrong-type-arg "make <link>"
+                  (G_ "#:target-iri and #:relation-type are required")
+                  '()
+                  (list `(,target-iri . ,relation-type))))
+     (when (string? target-iri)
+       (set! target-iri
+             (string->uri-reference target-iri)))
+     (unless (uri-reference? target-iri)
+       (scm-error 'wrong-type-arg "make <link>"
+                  (G_ "#:target-iri should be an URI reference")
+                  '()
+                  (list target-iri)))
+     (unless (string? relation-type)
+       (scm-error 'wrong-type-arg "make <link>"
+                  (G_ "#:relation-type should be a string")
+                  '()
+                  (list relation-type)))
+     (slot-set! link 'target-iri target-iri)
+     (slot-set! link 'relation-type relation-type)
+     (slot-set! link 'target-attributes `(,@extra-target-attributes ,@target-attributes)))))
+
+(define-method (initialize (attribute <target-attribute>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((attribute-key #f)
+    (attribute-value #f))
+   (when (string? attribute-key)
+     (set! attribute-key (string->symbol attribute-key))
+     (slot-set! attribute 'attribute-key attribute-key))
+   (when (uri? attribute-value)
+     (set! attribute-value (uri->string attribute-value))
+     (slot-set! attribute 'attribute-value attribute-value))
+   (unless (symbol? attribute-key)
+     (scm-error 'wrong-type-arg "make <target-attribute>"
+                (G_ "the #:attribute-key parameter should be a string or symbol")
+                '()
+                (list attribute-key)))
+   (unless (string? attribute-value)
+     (scm-error 'wrong-type-arg "make <target-attribute>"
+                (G_ "the #:attribute-value parameter should be a string or URI")
+                '()
+                (list attribute-value)))))
+
 (define-peg-string-patterns
   "links <-- link (comma link)*
 link <-- uri-reference (semicolon parameter)*
@@ -167,65 +382,113 @@ escape-return <-- '\\' 'r'
          value))
       (fix (list datum))))
 
+(define make-link
+  (match-lambda
+    (((? uri-reference? target-iri) attributes ...)
+     (let examine-attributes ((attributes attributes)
+                              (relation-type #f)
+                              (extra-attributes '()))
+       (match attributes
+         (()
+          (make <link>
+            #:target-iri target-iri
+            #:relation-type relation-type
+            #:target-attributes (reverse extra-attributes)))
+         ((('rel . new-relation-type) attributes ...)
+          (examine-attributes attributes
+                              (or relation-type new-relation-type)
+                              extra-attributes))
+         (((key . value) attributes ...)
+          (examine-attributes attributes relation-type
+                              `(,(make <target-attribute>
+                                   #:attribute-key key
+                                   #:attribute-value value)
+                                ,@extra-attributes))))))))
+
 (define (parse str)
   (let ((tree (peg:tree (match-pattern links str))))
-    (and tree (fix tree))))
+    (and tree
+         (let ((fixed (fix tree)))
+           (and fixed
+                (with-exception-handler
+                    (lambda (exn)
+                      (raise-exception exn))
+                  (lambda ()
+                    (map make-link fixed))))))))
 
 (define (validate links)
-  (define (validate-one-link link)
-    (define (validate-parameters params)
-      (define (validate-one-parameter parameter)
-        (or (symbol? parameter)
-            (and (pair? parameter)
-                 (symbol? (car parameter))
-                 (string? (cdr parameter)))))
-      (and (list? params)
-           (or (null? params)
-               (and (validate-one-parameter (car params))
-                    (validate-parameters (cdr params))))))
-    (and (list? link)
-         (uri-reference? (car link))
-         (validate-parameters (cdr link))))
-  (and (list? links)
-       (or (null? links)
-           (and (validate-one-link (car links))
-                (validate (cdr links))))))
-
-(define (write links port)
-  (define (replace-close-angle accu input)
-    (cond
-     ((null? input)
-      (list->string (reverse accu)))
-     ((eqv? (car input) #\>)
-      (replace-close-angle accu (cons* #\% #\3 #\E (cdr input))))
-     (else
-      (replace-close-angle (cons (car input) accu) (cdr input)))))
-  (define (escape accu input)
-    (cond
-     ((null? input)
-      (string-append "\"" (list->string (reverse accu)) "\""))
-     ((eqv? (car input) #\\)
-      (escape (cons* #\\ #\\ accu) (cdr input)))
-     ((eqv? (car input) #\")
-      (escape (cons* #\" #\\ accu) (cdr input)))
-     (else
-      (escape (cons (car input) accu) (cdr input)))))
-  (define (write-one-link link)
-    (define (write-parameters params)
-      (define (write-parameter param)
-        (if (symbol? param)
-            (string-append "; " (symbol->string param))
-            (format #f "; ~a=~a"
-                    (symbol->string (car param))
-                    (escape '() (string->list (cdr param))))))
-      (string-join (map write-parameter params) ""))
-    (string-append
-     "<"
-     (replace-close-angle '() (string->list (uri->string (car link))))
-     ">"
-     (write-parameters (cdr link))))
+  (and links #t))
+
+(define (escape-double str)
+  (let escape ((chars (string->list str))
+               (escaped '()))
+    (match chars
+      (() (list->string (reverse escaped)))
+      ((#\return chars ...)
+       (escape chars `(#\r #\\ ,@escaped)))
+      ((#\newline chars ...)
+       (escape chars `(#\n #\\ ,@escaped)))
+      ((#\tab chars ...)
+       (escape chars `(#\t #\\ ,@escaped)))
+      (((and needs-escape
+             (or #\\ #\"))
+        chars ...)
+       (escape chars `(,needs-escape #\\ ,@escaped)))
+      ((c chars ...)
+       (escape chars `(,c ,@escaped))))))
+
+(define-method (http-write (attribute <target-attribute>) port)
+  (format port
+          (if (string-suffix? "*" (symbol->string (attribute-key attribute)))
+              ;; Don’t put double quotes for title* and such
+              "~a=~a"
+              "~a=\"~a\"")
+          (attribute-key attribute)
+          (escape-double (attribute-value attribute))))
+
+(define-method (http-write (link <link>) port)
+  (let escape-target-iri ((target-iri-chars
+                           (string->list
+                            (uri->string
+                             (target-iri link))))
+                          (escaped-chars '()))
+    (match target-iri-chars
+      (()
+       (let ((target-iri-str
+              (list->string (reverse escaped-chars)))
+             (relation-type-str
+              (escape-double
+               (match (relation-type link)
+                 ((or (? uri? (= uri->string uri))
+                      (? string? uri))
+                  uri))))
+             (target-attributes-str
+              (map
+               (lambda (attr)
+                 (call-with-output-string
+                   (lambda (port)
+                     (display "; " port)
+                     (http-write attr port))))
+               (target-attributes link))))
+         (format port "<~a>; rel=\"~a\"~a"
+                 target-iri-str relation-type-str
+                 (string-join target-attributes-str ""))))
+      ((#\> target-iri-chars ...)
+       (escape-target-iri `(#\% #\3 #\E ,@target-iri-chars)
+                          escaped-chars))
+      ((c target-iri-chars ...)
+       (escape-target-iri target-iri-chars
+                          `(,c ,@escaped-chars))))))
+
+(define-method (http-write (links <list>) port)
   (display
-   (string-join (map write-one-link links) ", ")
+   (string-join
+    (map (lambda (link)
+           (call-with-output-string
+             (lambda (port)
+               (http-write link port))))
+         links)
+    ", ")
    port))
 
 (define (declare-link-header!)
@@ -237,7 +500,7 @@ escape-return <-- '\\' 'r'
          "Link"
          parse
          validate
-         write)))))
+         http-write)))))
 
 (define (request-links request)
   (apply append
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index d035ec4..989abd9 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -247,10 +247,10 @@
                 (receive (content-type content)
                     (nonrdf-or-turtle server-uri request request-body)
                   (let ((types
-                         (map car
+                         (map target-iri
                               (filter
                                (lambda (link)
-                                 (equal? (assq-ref link 'rel) "type"))
+                                 (equal? (relation-type link) "type"))
                                (request-links request)))))
                     (return
                      (build-response
diff --git a/src/scm/webid-oidc/server/delete.scm b/src/scm/webid-oidc/server/delete.scm
index 445622c..28a17df 100644
--- a/src/scm/webid-oidc/server/delete.scm
+++ b/src/scm/webid-oidc/server/delete.scm
@@ -21,7 +21,6 @@
   #:use-module (webid-oidc server precondition)
   #:use-module (webid-oidc cache)
   #:use-module (webid-oidc fetch)
-  #:use-module (webid-oidc http-link)
   #:use-module (webid-oidc server resource wac)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (webid-oidc rdf-index)
diff --git a/src/scm/webid-oidc/server/precondition.scm b/src/scm/webid-oidc/server/precondition.scm
index 7e3a4bb..244e288 100644
--- a/src/scm/webid-oidc/server/precondition.scm
+++ b/src/scm/webid-oidc/server/precondition.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -20,7 +20,6 @@
   #:use-module (webid-oidc server resource content)
   #:use-module (webid-oidc cache)
   #:use-module (webid-oidc fetch)
-  #:use-module (webid-oidc http-link)
   #:use-module (webid-oidc server resource wac)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (webid-oidc rdf-index)
diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm
index 73d32e3..f5a493b 100644
--- a/src/scm/webid-oidc/server/read.scm
+++ b/src/scm/webid-oidc/server/read.scm
@@ -112,51 +112,63 @@
                ;; Headers
                (let ((links
                       (let ((type
-                             `(,(string->uri
-                                 (string-append "http://www.w3.org/ns/ldp#"
-                                                (if container?
-                                                    "BasicContainer"
-                                                    "Resource")))
-                               (rel . "type")))
+                             (make <link>
+                               #:target-iri
+                               (string-append "http://www.w3.org/ns/ldp#"
+                                              (if container?
+                                                  "BasicContainer"
+                                                  "Resource"))
+                               #:relation-type "type"))
                             (acl
                              (and needs-acl?
-                                  `(,(build-uri
-                                      'https
-                                      #:userinfo (uri-userinfo server-name)
-                                      #:host (uri-host server-name)
-                                      #:port (uri-port server-name)
-                                      #:path (derive-path
-                                              base-path
-                                              (string->uri
-                                               "http://www.w3.org/ns/auth/acl#accessControl")))
-                                    (rel . "acl"))))
+                                  (make <link>
+                                    #:target-iri
+                                    (build-uri
+                                     'https
+                                     #:userinfo (uri-userinfo server-name)
+                                     #:host (uri-host server-name)
+                                     #:port (uri-port server-name)
+                                     #:path (derive-path
+                                             base-path
+                                             (string->uri
+                                              "http://www.w3.org/ns/auth/acl#accessControl")))
+                                    #:relation-type "acl")))
                             (describedby
                              (and needs-meta?
-                                  `(,(build-uri
-                                      'https
-                                      #:userinfo (uri-userinfo server-name)
-                                      #:host (uri-host server-name)
-                                      #:port (uri-port server-name)
-                                      #:path (derive-path
-                                              base-path
-                                              (string->uri
-                                               "https://www.w3.org/ns/iana/link-relations/relation#describedby")))
-                                    (rel . "describedby"))))
+                                  (make <link>
+                                    #:target-iri
+                                    (build-uri
+                                     'https
+                                     #:userinfo (uri-userinfo server-name)
+                                     #:host (uri-host server-name)
+                                     #:port (uri-port server-name)
+                                     #:path (derive-path
+                                             base-path
+                                             (string->uri
+                                              "https://www.w3.org/ns/iana/link-relations/relation#describedby")))
+                                    #:relation-type "describedby")))
                             (describes
                              (and needs-meta?
-                                  `(,(build-uri
-                                      'https
-                                      #:userinfo (uri-userinfo server-name)
-                                      #:host (uri-host server-name)
-                                      #:port (uri-port server-name)
-                                      #:path base-path)
-                                    (rel . "https://www.w3.org/ns/iana/link-relations/relation#describes"))))
+                                  (make <link>
+                                    #:target-iri
+                                    (build-uri
+                                     'https
+                                     #:userinfo (uri-userinfo server-name)
+                                     #:host (uri-host server-name)
+                                     #:port (uri-port server-name)
+                                     #:path base-path)
+                                    #:relation-type
+                                    "https://www.w3.org/ns/iana/link-relations/relation#describes")))
                             (storage
                              (and root?
-                                  `((,(string->uri "http://www.w3.org/ns/pim/space#Storage")
-                                     (rel . "type"))
-                                    (,owner
-                                     (rel . "http://www.w3.org/ns/solid/terms#owner"))))))
+                                  (list
+                                   (make <link>
+                                     #:target-iri
+                                     "http://www.w3.org/ns/pim/space#Storage"
+                                     #:relation-type "type")
+                                   (make <link>
+                                     #:target-iri owner
+                                     #:relation-type "http://www.w3.org/ns/solid/terms#owner")))))
                         (append
                          (list type)
                          (if acl (list acl) '())
diff --git a/src/scm/webid-oidc/server/update.scm b/src/scm/webid-oidc/server/update.scm
index 9bca2e6..49ed1fe 100644
--- a/src/scm/webid-oidc/server/update.scm
+++ b/src/scm/webid-oidc/server/update.scm
@@ -22,7 +22,6 @@
   #:use-module (webid-oidc server create) ;; for &unsupported-media-type
   #:use-module (webid-oidc cache)
   #:use-module (webid-oidc fetch)
-  #:use-module (webid-oidc http-link)
   #:use-module (webid-oidc server resource wac)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (webid-oidc rdf-index)
diff --git a/tests/crud.scm b/tests/crud.scm
index da3637a..38af286 100644
--- a/tests/crud.scm
+++ b/tests/crud.scm
@@ -23,6 +23,7 @@
   #:use-module (webid-oidc server resource path)
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc testing)
+  #:use-module (webid-oidc http-link)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (webid-oidc fetch)
   #:use-module (webid-oidc rdf-index)
@@ -31,6 +32,7 @@
   #:use-module (web response)
   #:use-module (web uri)
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:duplicates (merge-generics)
   #:declarative? #t)
@@ -133,18 +135,38 @@
              (accept-put (assq-ref headers-root 'accept-put))
              (content-type (assq-ref headers-root 'content-type))
              (etag (assq-ref headers-root 'etag)))
-         (unless (equal? (assoc-ref links (string->uri "http://www.w3.org/ns/ldp#BasicContainer"))
-                         '((rel . "type")))
-           (exit 6))
-         (unless (equal? (assoc-ref links (string->uri "https://example.com/.acl"))
-                         '((rel . "acl")))
-           (exit 7))
-         (unless (equal? (assoc-ref links (string->uri "http://www.w3.org/ns/pim/space#Storage"))
-                         '((rel . "type")))
-           (exit 8))
-         (unless (equal? (assoc-ref links owner)
-                         '((rel . "http://www.w3.org/ns/solid/terms#owner")))
-           (exit 9))
+         (let search-links ((links links)
+                            (container-type-found? #f)
+                            (acl-found? #f)
+                            (storage-type-found? #f)
+                            (owner-found? #f))
+           (match links
+             ((link links ...)
+              (cond
+               ((and (equal? (target-iri link) (string->uri "http://www.w3.org/ns/ldp#BasicContainer"))
+                     (equal? (relation-type link) "type"))
+                (search-links links #t acl-found? storage-type-found? owner-found?))
+               ((and (equal? (target-iri link) (string->uri "https://example.com/.acl"))
+                     (equal? (relation-type link) "acl"))
+                (search-links links container-type-found? #t storage-type-found? owner-found?))
+               ((and (equal? (target-iri link) (string->uri "http://www.w3.org/ns/pim/space#Storage"))
+                     (equal? (relation-type link) "type"))
+                (search-links links container-type-found? acl-found? #t owner-found?))
+               ((and (equal? (target-iri link) owner)
+                     (equal? (relation-type link) "http://www.w3.org/ns/solid/terms#owner"))
+                (search-links links container-type-found? acl-found? storage-type-found? #t))
+               (else
+                (format (current-error-port) "Ignoring link: ~s\n" link)
+                (search-links links container-type-found? acl-found? storage-type-found? owner-found?))))
+             (()
+              (unless container-type-found?
+                (exit 6))
+              (unless acl-found?
+                (exit 7))
+              (unless storage-type-found?
+                (exit 8))
+              (unless owner-found?
+                (exit 9)))))
          (unless (and (memq 'GET allow)
                       (memq 'HEAD allow)
                       (memq 'OPTIONS allow)
diff --git a/tests/http-link.scm b/tests/http-link.scm
index a16c353..062bb1a 100644
--- a/tests/http-link.scm
+++ b/tests/http-link.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -14,12 +14,40 @@
 ;; You should have received a copy of the GNU Affero General Public License
 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
-(use-modules (webid-oidc http-link)
-             (webid-oidc testing)
-             (web http)
-             (web request)
-             (web response)
-             (web uri))
+(define-module (tests http-link)
+  #:use-module (webid-oidc http-link)
+  #:use-module (webid-oidc testing)
+  #:use-module (web http)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (oop goops))
+
+(define-class <test-case> ()
+  (encoded-form #:init-keyword #:encoded-form #:getter encoded-form)
+  (decoded-form #:init-keyword #:decoded-form #:getter decoded-form)
+  (one-way? #:init-keyword #:one-way? #:getter one-way? #:init-value #f))
+
+(define-method (check (test <test-case>))
+  (let ((decoded (parse-header 'link (encoded-form test)))
+        (encoded (and (not (one-way? test))
+                      (call-with-output-string
+                        (lambda (port)
+                          (write-header 'link (decoded-form test) port))))))
+    (unless (and (equal? decoded (decoded-form test))
+                 (or (one-way? test)
+                     (equal? encoded (format #f "Link: ~a\r\n" (encoded-form test)))))
+      (format (current-error-port) "Test case failed:
+~s:
+           -> ~s
+    (expected ~s)
+~s:
+           -> ~s
+    (expected ~s)
+"
+              (encoded-form test) decoded (decoded-form test)
+              (decoded-form test) encoded (format #f "Link: ~a\r\n" (encoded-form test)))
+      (exit 1))))
 
 (with-test-environment
  "http-link"
@@ -27,63 +55,85 @@
    (declare-link-header!)
    ;; Declare it twice to check that there’s no problem
    (declare-link-header!)
-   (let ((example-zero "<>")
-         (example-one "<h>")
-         (example-two "<https://two.example.com>; ok")
-         (example-three "<https://three.example.com>; a=b")
-         (example-four "<https://four.example.com>; a=\"\\\\b\\n\"")
-         (example-five "<https://five.example.com>; ok; a=b; a=\"\\\\b\\n\"")
-         (expected-zero "Link: <>\r\n")
-         (expected-one "Link: <h>\r\n")
-         (expected-two "Link: <https://two.example.com>; ok\r\n")
-         (expected-three "Link: <https://three.example.com>; a=\"b\"\r\n")
-         (expected-four "Link: <https://four.example.com>; a=\"\\\\b\n\"\r\n")
-         (expected-five "Link: <https://five.example.com>; ok; a=\"b\"; a=\"\\\\b\n\"\r\n"))
-     (let ((example-six
-            (string-join (list
-                          example-zero
-                          example-one
-                          example-two
-                          example-three
-                          example-four
-                          example-five)
-                         ", "))
-           (expected-six
-            "Link: <>, <h>, <https://two.example.com>; ok, <https://three.example.com>; a=\"b\", <https://four.example.com>; a=\"\\\\b\n\", <https://five.example.com>; ok; a=\"b\"; a=\"\\\\b\n\"\r\n"))
-       (define (test str)
-         (let ((parsed (parse-header 'link str)))
-           (call-with-output-string
-             (lambda (port)
-               (write-header 'link parsed port)))))
-       (let ((zero (test example-zero))
-             (one (test example-one))
-             (two (test example-two))
-             (three (test example-three))
-             (four (test example-four))
-             (five (test example-five))
-             (six (test example-six)))
-         (unless (equal? zero expected-zero)
-           (exit 1))
-         (unless (equal? one expected-one)
-           (exit 2))
-         (unless (equal? two expected-two)
-           (exit 3))
-         (unless (equal? three expected-three)
-           ;; This test is the first to fail if the Link header
-           ;; handler is not installed.
-           (exit 4))
-         (unless (equal? four expected-four)
-           (exit 5))
-         (unless (equal? five expected-five)
-           (exit 6))
-         (unless (equal? six expected-six)
-           (exit 7)))))
+   (let ((cases
+          ;; These test cases are copied from rfc8288
+          (list
+           (make <test-case>
+             #:encoded-form
+             "<http://example.com/TheBook/chapter2>; rel=\"previous\"; title=\"previous chapter\""
+             #:decoded-form
+             (list
+              (make <link>
+                #:target-iri "http://example.com/TheBook/chapter2"
+                #:relation-type "previous"
+                #:title "previous chapter")))
+           (make <test-case>
+             #:encoded-form
+             "</>; rel=\"http://example.net/foo\""
+             #:decoded-form
+             (list
+              (make <link>
+                #:target-iri "/"
+                #:relation-type "http://example.net/foo")))
+           (make <test-case>
+             #:encoded-form
+             "</terms>; rel=\"copyright\"; anchor=\"#foo\""
+             #:decoded-form
+             (list
+              (make <link>
+                #:target-iri "/terms"
+                #:relation-type "copyright"
+                #:anchor "#foo")))
+           (make <test-case>
+             #:encoded-form
+             "</TheBook/chapter2>; rel=\"previous\"; title*=UTF-8'de'letztes%20Kapitel, </TheBook/chapter4>; rel=\"next\"; title*=UTF-8'de'n%c3%a4chstes%20Kapitel"
+             #:decoded-form
+             (list
+              (make <link>
+                #:target-iri "/TheBook/chapter2"
+                #:relation-type "previous"
+                #:title* "UTF-8'de'letztes%20Kapitel")
+              (make <link>
+                #:target-iri "/TheBook/chapter4"
+                #:relation-type "next"
+                #:title* "UTF-8'de'n%c3%a4chstes%20Kapitel")))
+           ;; These tests are mine, they check for more edge cases
+           (make <test-case>
+             #:encoded-form
+             "<https://example.com>; rel=\"b\""
+             #:decoded-form
+             (list
+              (make <link>
+                #:target-iri "https://example.com"
+                #:relation-type "b")))
+           (make <test-case>
+             #:encoded-form
+             "<https://example.com>; rel=\"\\\\b\\n\""
+             #:decoded-form
+             (list
+              (make <link>
+                #:target-iri "https://example.com"
+                #:relation-type "\\b\n")))
+           (make <test-case>
+             #:encoded-form
+             "<https://example.com>; rel=\"\\\\b\\n\""
+             #:decoded-form
+             (list
+              (make <link>
+                #:target-iri "https://example.com"
+                #:relation-type "\\b\n"))))))
+     (for-each check cases))
+   ;; Now, we check that the request / response API works
    (let ((first-link-uri (string->uri "https://example.com/vocab#link"))
          (second-link-uri (string->uri "https://example.com/vocab#type")))
      (let ((first-link
-            `(,first-link-uri (rel . "type")))
+            (make <link>
+              #:target-iri first-link-uri
+              #:relation-type "type"))
            (second-link
-            `(,second-link-uri (rel . "type"))))
+            (make <link>
+              #:target-iri second-link-uri
+              #:relation-type "type")))
        (let ((request (build-request
                        (string->uri "https://example.com")
                        #:headers
@@ -93,6 +143,10 @@
            (let ((links (response-links response)))
              (unless (equal? links
                              (list
-                              (list (string->uri "https://example.com/vocab#link") (cons 'rel "type"))
-                              (list (string->uri "https://example.com/vocab#type") (cons 'rel "type"))))
+                              (make <link>
+                                #:target-iri "https://example.com/vocab#link"
+                                #:relation-type "type")
+                              (make <link>
+                                #:target-iri "https://example.com/vocab#type"
+                                #:relation-type "type")))
                (exit 8)))))))))