HTTP Link header: use GOOPS and document it

2 files changed, 150 insertions, 74 deletions

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)))))))))