From c6563268a6571b158a8a82fe4ca88f2802ee6aa9 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Sat, 19 Jun 2021 10:54:43 +0200
Subject: Implement the GET, HEAD, OPTIONS methods for the server

---
 tests/crud.scm | 107 +++++++++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 105 insertions(+), 2 deletions(-)

(limited to 'tests/crud.scm')

diff --git a/tests/crud.scm b/tests/crud.scm
index 422b1da..222bcc3 100644
--- a/tests/crud.scm
+++ b/tests/crud.scm
@@ -1,12 +1,17 @@
 (use-modules (webid-oidc server create)
+             (webid-oidc server read)
              (webid-oidc server resource content)
              (webid-oidc server resource path)
              (webid-oidc errors)
              (webid-oidc testing)
+             (webid-oidc fetch)
+             (webid-oidc rdf-index)
              (web http)
              (web request)
              (web response)
-             (web uri))
+             (web uri)
+             (ice-9 receive)
+             (rnrs bytevectors))
 
 (with-test-environment
  "crud"
@@ -40,6 +45,7 @@
       "i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE"))
    (let ((server-name (string->uri "https://example.com"))
          (owner (string->uri "https://alice.databox.me")))
+     ;; CREATE
      (unless
          (create-root server-name owner)
        (exit 1))
@@ -77,4 +83,101 @@
             (exit 5))
           #:unwind? #t
           #:unwind-for-type &path-is-auxiliary))
-      '(".acl" ".meta")))))
+      '(".acl" ".meta"))
+     ;; READ
+     (receive (headers-root root) (read server-name owner owner "/")
+       ;; For root, we’re looking for the following headers:
+       ;; - link: ldp:BasicContainer; rel = "type", </.acl>; rel = "acl", pim:Storage; rel = "type", owner; rel = "solid:owner"
+       ;; - allow: GET, HEAD, OPTIONS, PUT, POST, but not DELETE
+       ;; - accept-put: 'text/turtle
+       ;; - content-type: 'text/turtle
+       ;; - etag: weak
+       ;; The content is a RDF graph, it should contain 1 triple: </> ldp:contains </inbox>.
+       (when (bytevector? root)
+         (set! root (utf8->string root)))
+       (let ((links (assq-ref headers-root 'link))
+             (allow (assq-ref headers-root 'allow))
+             (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))
+         (unless (and (memq 'GET allow)
+                      (memq 'HEAD allow)
+                      (memq 'OPTIONS allow)
+                      (memq 'PUT allow)
+                      (memq 'POST allow))
+           (exit 10))
+         (when (memq 'DELETE allow)
+           (exit 11))
+         (unless (equal? accept-put "text/turtle")
+           (exit 12))
+         (unless (equal? content-type '(text/turtle))
+           (exit 13))
+         (unless (string? (car etag))
+           (exit 14))
+         (when (cdr etag)
+           (exit 15))
+         (with-index
+          (fetch "https://example.com/"
+                 #:http-get
+                 (lambda (uri . rest)
+                   (values
+                    (build-response #:headers `((content-type . ,content-type)))
+                    root)))
+          (lambda (rdf-match)
+            (when (null? (rdf-match "https://example.com/"
+                                    "http://www.w3.org/ns/ldp#contains"
+                                    "https://example.com/inbox/"))
+              (exit 16))))))
+     (receive (headers-/.acl /.acl) (read server-name owner owner "/.acl")
+       ;; The ACL has the following headers:
+       ;; - allow: GET, HEAD, OPTIONS, PUT, DELETE, but not POST
+       ;; - accept-put: 'text/turtle
+       ;; - content-type: 'text/turtle
+       ;; - etag: weak
+       ;; The content is a RDF graph containing at least one authorization.
+       (when (bytevector? /.acl)
+         (set! /.acl (utf8->string /.acl)))
+       (let ((allow (assq-ref headers-/.acl 'allow))
+             (accept-put (assq-ref headers-/.acl 'accept-put))
+             (content-type (assq-ref headers-/.acl 'content-type))
+             (etag (assq-ref headers-/.acl 'etag)))
+         (unless (and (memq 'GET allow)
+                      (memq 'HEAD allow)
+                      (memq 'OPTIONS allow)
+                      (memq 'PUT allow)
+                      (memq 'DELETE allow))
+           (exit 17))
+         (when (memq 'POST allow)
+           (exit 18))
+         (unless (equal? accept-put "text/turtle")
+           (exit 19))
+         (unless (equal? content-type '(text/turtle))
+           (exit 20))
+         (unless (string? (car etag))
+           (exit 21))
+         (when (cdr etag)
+           (exit 22))
+         (with-index
+          (fetch "https://example.com/.acl"
+                 #:http-get
+                 (lambda (uri . rest)
+                   (values
+                    (build-response #:headers `((content-type . ,content-type)))
+                    /.acl)))
+          (lambda (rdf-match)
+            (when (null? (rdf-match #f
+                                    "http://www.w3.org/1999/02/22-rdf-syntax-ns#type"
+                                    "http://www.w3.org/ns/auth/acl#Authorization"))
+              (exit 23)))))))))
-- 
cgit v1.2.3