diff options
Diffstat (limited to 'tests/server-path.scm')
-rw-r--r-- | tests/server-path.scm | 233 |
1 files changed, 116 insertions, 117 deletions
diff --git a/tests/server-path.scm b/tests/server-path.scm index b497dae..f4f4219 100644 --- a/tests/server-path.scm +++ b/tests/server-path.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,17 +14,20 @@ ;; 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 server resource content) - (webid-oidc server resource path) - (webid-oidc fetch) - (webid-oidc testing) - (webid-oidc errors) - (web uri) - (web response) - (rnrs bytevectors) - (ice-9 optargs) - (ice-9 receive) - (oop goops)) +(define-module (tests server-path) + #:use-module (webid-oidc server resource content) + #:use-module (webid-oidc server resource path) + #:use-module (webid-oidc fetch) + #:use-module (webid-oidc testing) + #:use-module (webid-oidc errors) + #:use-module (web uri) + #:use-module (web response) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (oop goops) + #:declarative? #t + #:duplicates (merge-generics)) (with-test-environment "server-path" @@ -54,114 +57,110 @@ "tests/server-path.home/disfluid/server/path/Q/hRrKeOf3iJxfvabWz2CBYAlF_ovDFXqHWcwhhuQhXg" "tests/server-path.home/disfluid/server/path/Q/hRrKeOf3iJxfvabWz2CBYAlF_ovDFXqHWcwhhuQhXg.lock" )) - (with-session - (lambda (content-type contained static-content create delete) - (let ((new-etag - (lambda () - (create 'text/plain '() "Hello :)"))) - (new-acl - (lambda () - (create 'text/turtle '() - "@prefix acl: <http://www.w3.org/ns/auth/acl#>. + (parameterize ((current-content-cache (make <content-cache>))) + (let ((new + (lambda () + (make <content> + #:content-type 'text/plain + #:static-content "Hello :)"))) + (new-acl + (lambda () + (make <content> + #:content-type 'text/turtle + #:contained '() + #:static-content + "@prefix acl: <http://www.w3.org/ns/auth/acl#>. <#authorized> a acl:Authorization; acl:accessTo <https://example.com/a/b/c>; acl:mode acl:Read; acl:agent <https://friend.example.com/profile/card#me>. ")))) - ;; Create with parents: - (update-path - "/a/b/c" - (lambda (etag auxiliary) - (when (or etag auxiliary) - (exit 1)) - (values (new-etag) `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") . ,(new-acl))))) - content-type contained static-content create delete - #:create-intermediate-containers? #t) - ;; So now, there should be a chain of directories: - (receive (root-etag root-aux) - (read-path "/") - (let ((root-children (contained root-etag))) - (unless (equal? root-children '("/a/")) - (exit 2))) - (unless (null? root-aux) - (exit 3))) - (receive (/a/ /a/-aux) - (read-path "/a/") - (unless (equal? (contained /a/) '("/a/b/")) - (exit 4)) - (unless (null? /a/-aux) - (exit 5))) - (receive (/a/b/ /a/b/-aux) - (read-path "/a/b/") - (unless (equal? (contained /a/b/) '("/a/b/c")) - (exit 6)) - (unless (null? /a/b/-aux) - (exit 7))) - (receive (/a/b/c /a/b/c-aux) - (read-path "/a/b/c") - (unless (equal? (content-type /a/b/c) 'text/plain) - (exit 8)) - (unless (equal? (static-content /a/b/c) - (string->utf8 "Hello :)")) - (exit 9))) - ;; We can delete /a/b/c - (update-path "/a/b/c" (lambda (etag aux) #f) - content-type contained static-content create delete) - ;; Now /a/b/c does not exist - (with-exception-handler - (lambda (error) - (unless (path-not-found? error) - (exit 10))) - (lambda () - (read-path "/a/b/c") - (exit 11)) - #:unwind? #t - #:unwind-for-type &path-not-found) - ;; We can’t delete /a/ because there's /a/b/ in it - (with-exception-handler - (lambda (error) - (unless (container-not-empty? error) - (exit 12)) - (unless (equal? (container-not-empty-path error) "/a/") - (exit 13))) - (lambda () - (update-path "/a/" (lambda (etag aux) #f) - content-type contained static-content create delete) - (exit 14)) - #:unwind? #t - #:unwind-for-type &container-not-empty) - ;; However, we can recreate /a/b/c without creating intermediate containers - (update-path "/a/b/c" - (lambda (etag aux) - (values (new-etag) - `((,(string->uri - "http://www.w3.org/ns/auth/acl#accessControl") - . ,(new-acl))))) - content-type contained static-content create delete - #:create-intermediate-containers? #f) - ;; Delete /a/b/c again - (update-path "/a/b/c" (lambda (etag aux) #f) - content-type contained static-content create delete) - ;; Delete /a/b/ - (update-path "/a/b/" (lambda (etag aux) #f) - content-type contained static-content create delete) - ;; Delete /a/ - (update-path "/a/" (lambda (etag aux) #f) - content-type contained static-content create delete) - ;; Cannot delete the root - (with-exception-handler - (lambda (error) - (unless (cannot-delete-root? error) - (exit 15))) - (lambda () - (update-path "/" (lambda (etag aux) #f) - content-type contained static-content create delete) - (exit 16)) - #:unwind? #t - #:unwind-for-type &cannot-delete-root) - ;; However, the root should be empty - (receive (root-etag root-aux) - (read-path "/") - (unless (null? (contained root-etag)) - (exit 17)))))))) + ;; Create with parents: + (update-path + "/a/b/c" + (lambda (main auxiliary) + (when (or main auxiliary) + (exit 1)) + (values (new) `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") . ,(new-acl))))) + #:create-intermediate-containers? #t) + ;; So now, there should be a chain of directories: + (receive (root root-aux) + (read-path "/") + (let ((root-children (contained root))) + (unless (equal? root-children '("/a/")) + (exit 2))) + (unless (null? root-aux) + (exit 3))) + (receive (/a/ /a/-aux) + (read-path "/a/") + (unless (equal? (contained /a/) '("/a/b/")) + (exit 4)) + (unless (null? /a/-aux) + (exit 5))) + (receive (/a/b/ /a/b/-aux) + (read-path "/a/b/") + (unless (equal? (contained /a/b/) '("/a/b/c")) + (exit 6)) + (unless (null? /a/b/-aux) + (exit 7))) + (receive (/a/b/c /a/b/c-aux) + (read-path "/a/b/c") + (unless (equal? (content-type /a/b/c) 'text/plain) + (exit 8)) + (unless (equal? (static-content /a/b/c) + (string->utf8 "Hello :)")) + (exit 9))) + ;; We can delete /a/b/c + (update-path "/a/b/c" (lambda (main aux) #f)) + ;; Now /a/b/c does not exist + (with-exception-handler + (lambda (error) + (unless (path-not-found? error) + (exit 10))) + (lambda () + (read-path "/a/b/c") + (exit 11)) + #:unwind? #t + #:unwind-for-type &path-not-found) + ;; We can’t delete /a/ because there's /a/b/ in it + (with-exception-handler + (lambda (error) + (unless (container-not-empty? error) + (exit 12)) + (unless (equal? (container-not-empty-path error) "/a/") + (exit 13))) + (lambda () + (update-path "/a/" (lambda (main aux) #f)) + (exit 14)) + #:unwind? #t + #:unwind-for-type &container-not-empty) + ;; However, we can recreate /a/b/c without creating intermediate containers + (update-path "/a/b/c" + (lambda (main aux) + (values (new) + `((,(string->uri + "http://www.w3.org/ns/auth/acl#accessControl") + . ,(new-acl))))) + #:create-intermediate-containers? #f) + ;; Delete /a/b/c again + (update-path "/a/b/c" (lambda (main aux) #f)) + ;; Delete /a/b/ + (update-path "/a/b/" (lambda (main aux) #f)) + ;; Delete /a/ + (update-path "/a/" (lambda (main aux) #f)) + ;; Cannot delete the root + (with-exception-handler + (lambda (error) + (unless (cannot-delete-root? error) + (exit 15))) + (lambda () + (update-path "/" (lambda (main aux) #f)) + (exit 16)) + #:unwind? #t + #:unwind-for-type &cannot-delete-root) + ;; However, the root should be empty + (receive (root root-aux) + (read-path "/") + (unless (null? (contained root)) + (exit 17))))))) |