diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-30 10:30:40 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-04 22:51:36 +0200 |
commit | 4a144d76950ac002996c3941c1eb4a5a6de6a661 (patch) | |
tree | cb7d3ec06647d1ceff2cb638064fc650c0f98622 /tests | |
parent | 668aa5736b2709e15e3ea14381e010c8646a4c38 (diff) |
Content API: use GOOPS for the cache
Diffstat (limited to 'tests')
-rw-r--r-- | tests/acl.scm | 344 | ||||
-rw-r--r-- | tests/crud.scm | 50 | ||||
-rw-r--r-- | tests/server-content.scm | 88 | ||||
-rw-r--r-- | tests/server-path.scm | 233 |
4 files changed, 373 insertions, 342 deletions
diff --git a/tests/acl.scm b/tests/acl.scm index 9a11eb6..b28bbde 100644 --- a/tests/acl.scm +++ b/tests/acl.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,15 +14,19 @@ ;; 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 wac) - (webid-oidc server resource content) - (webid-oidc server resource path) - ((webid-oidc parameters) #:prefix p:) - (webid-oidc testing) - (web http) - (web request) - (web response) - (web uri)) +(define-module (tests acl) + #:use-module (webid-oidc server resource wac) + #:use-module (webid-oidc server resource content) + #:use-module (webid-oidc server resource path) + #:use-module ((webid-oidc parameters) #:prefix p:) + #: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) + #:duplicates (merge-generics) + #:declarative? #t) (define (http-get uri . other-args) (when (string? uri) @@ -63,25 +67,51 @@ "b/k7RqZevpCHAumba" "y/29x0MEOMybxUqDU" "5/KVojpXDg0Aob3_v")) - (with-session - (lambda (content-type contained static-content create delete) - ;; In this little scenario: - ;; / can only be listed by Alice and the FBI - ;; /docs/ can only be updated by Alice and the public can list - ;; /docs/file1 can only be updated by Alice, but public - ;; /docs/file2 same, but authenticated - ;; /fiction/file does not exist, so /#default applies - ;; /private-docs/ private to Alice, no ACL - ;; /private-docs/file1 no ACL (so, readable by the FBI as inherited in /) - ;; /private/docs/file2 no ACL (so, not readable by the FBI) - (let ((/ (create 'text/turtle '("docs" "private-docs") "")) - (/docs/ (create 'text/turtle '("file1" "file2") "")) - (/docs/file1 (create 'text/plain #f "Hello :)")) - (/docs/file2 (create 'text/plain #f "You’re authenticated :)")) - (/private-docs/ (create 'text/turtle '("file1") "")) - (/private-docs/file1 (create 'text/plain #f "Private, but FBI can read!")) - (/private-docs/file2 (create 'text/plain #f "Private!")) - (/.acl (create 'text/turtle #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . + (parameterize ((current-content-cache (make <content-cache>))) + ;; In this little scenario: + ;; / can only be listed by Alice and the FBI + ;; /docs/ can only be updated by Alice and the public can list + ;; /docs/file1 can only be updated by Alice, but public + ;; /docs/file2 same, but authenticated + ;; /fiction/file does not exist, so /#default applies + ;; /private-docs/ private to Alice, no ACL + ;; /private-docs/file1 no ACL (so, readable by the FBI as inherited in /) + ;; /private/docs/file2 no ACL (so, not readable by the FBI) + (let ((/ + (make <content> + #:content-type 'text/turtle + #:contained '("docs" "private-docs") + #:static-content "")) + (/docs/ + (make <content> + #:content-type 'text/turtle + #:contained '("file1" "file2") + #:static-content "")) + (/docs/file1 + (make <content> + #:content-type 'text/plain + #:static-content "Hello :)")) + (/docs/file2 + (make <content> + #:content-type 'text/plain + #:static-content "You’re authenticated :)")) + (/private-docs/ + (make <content> + #:content-type 'text/turtle + #:contained '("file1") + #:static-content "")) + (/private-docs/file1 + (make <content> + #:content-type 'text/plain + #:static-content "Private, but FBI can read!")) + (/private-docs/file2 + (make <content> + #:content-type 'text/plain + #:static-content "Private!")) + (/.acl + (make <content> + #:content-type 'text/turtle + #:static-content "@prefix acl: <http://www.w3.org/ns/auth/acl#> . <#default> a acl:Authorization; @@ -97,7 +127,10 @@ acl:mode acl:Read, acl:Write; acl:default <https://alice.databox.me/private-docs/file1>. ")) - (/docs/.acl (create 'text/turtle #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . + (/docs/.acl + (make <content> + #:content-type 'text/turtle + #:static-content "@prefix acl: <http://www.w3.org/ns/auth/acl#> . @prefix foaf: <http://xmlns.com/foaf/0.1/>. <#default> @@ -112,7 +145,10 @@ acl:agentClass foaf:Agent; acl:mode acl:Read. ")) - (/docs/file1.acl (create 'text/turtle #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . + (/docs/file1.acl + (make <content> + #:content-type 'text/turtle + #:static-content "@prefix acl: <http://www.w3.org/ns/auth/acl#> . @prefix foaf: <http://xmlns.com/foaf/0.1/>. <#default> @@ -127,7 +163,10 @@ acl:agentClass foaf:Agent; acl:mode acl:Read. ")) - (/docs/file2.acl (create 'text/turtle #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . + (/docs/file2.acl + (make <content> + #:content-type 'text/turtle + #:static-content "@prefix acl: <http://www.w3.org/ns/auth/acl#> . <#default> a acl:Authorization; @@ -141,127 +180,120 @@ acl:agentClass acl:AuthenticatedAgent; acl:mode acl:Read. "))) - (update-path - "/" - (lambda (main auxiliary) - (values / - `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") - . ,/.acl)))) - content-type contained static-content create delete) - (update-path - "/docs/" - (lambda (main auxiliary) - (values /docs/ - `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") - . ,/docs/.acl)))) - content-type contained static-content create delete) - (update-path - "/docs/file1" - (lambda (main auxiliary) - (values /docs/file1 - `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") - . ,/docs/file1.acl)))) - content-type contained static-content create delete) - (update-path - "/docs/file2" - (lambda (main auxiliary) - (values /docs/file2 - `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") - . ,/docs/file2.acl)))) - content-type contained static-content create delete) - (update-path - "/private-docs/" - (lambda (main auxiliary) - (values /private-docs/ '())) - content-type contained static-content create delete) - (update-path - "/private-docs/file1" - (lambda (main auxiliary) - (values /private-docs/file1 '())) - content-type contained static-content create delete) - (update-path - "/private-docs/file2" - (lambda (main auxiliary) - (values /private-docs/file2 '())) - content-type contained static-content create delete) - (let ((server-name - (string->uri "https://alice.databox.me"))) - ;; Who can access what? - ;; Alice: https://alice.databox.me/profile/card#me - ;; Bob: https://bob.databox.me/profile/card#me (authenticated) - ;; FBI: https://the-spy.databox.me/profile/card#me - ;; Anonymous - ;; - ;; Alice Bob FBI Anonymous - ;; / RWC X RW X - ;; /docs/ RWC R R R - ;; /docs/file1 RWC R R R - ;; /docs/file2 RWC R R X - ;; /fiction/file RWC X X X - ;; /private-docs/ RWC X X X - ;; /private-docs/file1 RWC X RW X - ;; /private-docs/file2 RWC X X X - (define (run-test path modes-alice modes-bob modes-fbi modes-anonymous) - (define (uri< a b) - (string< (uri->string a) (uri->string b))) - (parameterize - ((p:anonymous-http-request http-get)) - (let ((alice (wac-get-modes - server-name path - (string->uri "https://alice.databox.me/profile/card#me"))) - (bob (wac-get-modes - server-name path - (string->uri "https://bob.databox.me/profile/card#me"))) - (fbi (wac-get-modes - server-name path - (string->uri "https://the-spy.databox.me/profile/card#me"))) - (anonymous (wac-get-modes - server-name path - #f))) - (unless (equal? alice - modes-alice) - (format (current-error-port) - "Alice’s modes for path ~s:\n expected:\n ~s\n got:\n ~s\n" - path - (map uri->string modes-alice) - (map uri->string alice)) - (exit 2)) - (unless (equal? bob - modes-bob) - (format (current-error-port) - "Bob’s modes for path ~s:\n expected:\n ~s\n got:\n ~s\n" - path - (map uri->string modes-bob) - (map uri->string bob)) - (exit 3)) - (unless (equal? fbi - modes-fbi) - (format (current-error-port) - "Spy’s modes for path ~s:\n expected:\n ~s\n got:\n ~s\n" - path - (map uri->string modes-fbi) - (map uri->string fbi)) - (exit 4)) - (unless (equal? anonymous - modes-anonymous) - (format (current-error-port) - "Anonymous modes for path ~s:\n expected:\n ~s\n got:\n ~s\n" - path - (map uri->string modes-anonymous) - (map uri->string anonymous)) - (exit 5))))) - (let ((read (string->uri "http://www.w3.org/ns/auth/acl#Read")) - (write (string->uri "http://www.w3.org/ns/auth/acl#Write")) - (control (string->uri "http://www.w3.org/ns/auth/acl#Control"))) - (let ((RWC (list control read write)) - (R (list read)) - (RW (list read write)) - (X '())) - (run-test "/" RWC X RW X) - (run-test "/docs/" RWC R R R) - (run-test "/docs/file1" RWC R R R) - (run-test "/docs/file2" RWC R R X) - (run-test "/fiction/file" RWC X X X) - (run-test "/private-docs/" RWC X X X) - (run-test "/private-docs/file1" RWC X RW X) - (run-test "/private-docs/file2" RWC X X X))))))))) + (update-path + "/" + (lambda (main auxiliary) + (values / + `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") + . ,/.acl))))) + (update-path + "/docs/" + (lambda (main auxiliary) + (values /docs/ + `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") + . ,/docs/.acl))))) + (update-path + "/docs/file1" + (lambda (main auxiliary) + (values /docs/file1 + `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") + . ,/docs/file1.acl))))) + (update-path + "/docs/file2" + (lambda (main auxiliary) + (values /docs/file2 + `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") + . ,/docs/file2.acl))))) + (update-path + "/private-docs/" + (lambda (main auxiliary) + (values /private-docs/ '()))) + (update-path + "/private-docs/file1" + (lambda (main auxiliary) + (values /private-docs/file1 '()))) + (update-path + "/private-docs/file2" + (lambda (main auxiliary) + (values /private-docs/file2 '()))) + (let ((server-name + (string->uri "https://alice.databox.me"))) + ;; Who can access what? + ;; Alice: https://alice.databox.me/profile/card#me + ;; Bob: https://bob.databox.me/profile/card#me (authenticated) + ;; FBI: https://the-spy.databox.me/profile/card#me + ;; Anonymous + ;; + ;; Alice Bob FBI Anonymous + ;; / RWC X RW X + ;; /docs/ RWC R R R + ;; /docs/file1 RWC R R R + ;; /docs/file2 RWC R R X + ;; /fiction/file RWC X X X + ;; /private-docs/ RWC X X X + ;; /private-docs/file1 RWC X RW X + ;; /private-docs/file2 RWC X X X + (define (run-test path modes-alice modes-bob modes-fbi modes-anonymous) + (define (uri< a b) + (string< (uri->string a) (uri->string b))) + (parameterize + ((p:anonymous-http-request http-get)) + (let ((alice (wac-get-modes + server-name path + (string->uri "https://alice.databox.me/profile/card#me"))) + (bob (wac-get-modes + server-name path + (string->uri "https://bob.databox.me/profile/card#me"))) + (fbi (wac-get-modes + server-name path + (string->uri "https://the-spy.databox.me/profile/card#me"))) + (anonymous (wac-get-modes + server-name path + #f))) + (unless (equal? alice + modes-alice) + (format (current-error-port) + "Alice’s modes for path ~s:\n expected:\n ~s\n got:\n ~s\n" + path + (map uri->string modes-alice) + (map uri->string alice)) + (exit 2)) + (unless (equal? bob + modes-bob) + (format (current-error-port) + "Bob’s modes for path ~s:\n expected:\n ~s\n got:\n ~s\n" + path + (map uri->string modes-bob) + (map uri->string bob)) + (exit 3)) + (unless (equal? fbi + modes-fbi) + (format (current-error-port) + "Spy’s modes for path ~s:\n expected:\n ~s\n got:\n ~s\n" + path + (map uri->string modes-fbi) + (map uri->string fbi)) + (exit 4)) + (unless (equal? anonymous + modes-anonymous) + (format (current-error-port) + "Anonymous modes for path ~s:\n expected:\n ~s\n got:\n ~s\n" + path + (map uri->string modes-anonymous) + (map uri->string anonymous)) + (exit 5))))) + (let ((read (string->uri "http://www.w3.org/ns/auth/acl#Read")) + (write (string->uri "http://www.w3.org/ns/auth/acl#Write")) + (control (string->uri "http://www.w3.org/ns/auth/acl#Control"))) + (let ((RWC (list control read write)) + (R (list read)) + (RW (list read write)) + (X '())) + (run-test "/" RWC X RW X) + (run-test "/docs/" RWC R R R) + (run-test "/docs/file1" RWC R R R) + (run-test "/docs/file2" RWC R R X) + (run-test "/fiction/file" RWC X X X) + (run-test "/private-docs/" RWC X X X) + (run-test "/private-docs/file1" RWC X RW X) + (run-test "/private-docs/file2" RWC X X X)))))))) diff --git a/tests/crud.scm b/tests/crud.scm index fa33138..da3637a 100644 --- a/tests/crud.scm +++ b/tests/crud.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,23 +14,26 @@ ;; 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 create) - (webid-oidc server read) - (webid-oidc server update) - (webid-oidc server delete) - (webid-oidc server resource content) - (webid-oidc server resource path) - (webid-oidc errors) - (webid-oidc testing) - ((webid-oidc parameters) #:prefix p:) - (webid-oidc fetch) - (webid-oidc rdf-index) - (web http) - (web request) - (web response) - (web uri) - (ice-9 receive) - (rnrs bytevectors)) +(define-module (tests crud) + #:use-module (webid-oidc server create) + #:use-module ((webid-oidc server read) #:prefix server:) + #:use-module (webid-oidc server update) + #:use-module ((webid-oidc server delete) #:prefix server:) + #:use-module (webid-oidc server resource content) + #:use-module (webid-oidc server resource path) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc testing) + #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module (webid-oidc fetch) + #:use-module (webid-oidc rdf-index) + #:use-module (web http) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (ice-9 receive) + #:use-module (rnrs bytevectors) + #:duplicates (merge-generics) + #:declarative? #t) (with-test-environment "crud" @@ -115,7 +118,7 @@ #:unwind-for-type &path-is-auxiliary)) '(".acl" ".meta")) ;; READ - (receive (headers-root root) (read server-name owner owner "/") + (receive (headers-root root) (server: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 @@ -170,7 +173,7 @@ "http://www.w3.org/ns/ldp#contains" "https://example.com/inbox/")) (exit 16)))))) - (receive (headers-/.acl /.acl) (read server-name owner owner "/.acl") + (receive (headers-/.acl /.acl) (server: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 @@ -255,11 +258,10 @@ ")) (update server-name owner owner "/inbox/" #f #f 'text/turtle exact-content) (receive (headers content) - (read server-name owner owner "/inbox/") + (server:read server-name owner owner "/inbox/") (when (bytevector? content) (set! content (utf8->string content))) (when (equal? content exact-content) (exit 25)))) - (delete server-name owner owner "/inbox/test-notifications/welcome" #f #f) - (delete server-name owner owner "/inbox/test-notifications" #f #f)))) - + (server:delete server-name owner owner "/inbox/test-notifications/welcome" #f #f) + (server:delete server-name owner owner "/inbox/test-notifications" #f #f)))) diff --git a/tests/server-content.scm b/tests/server-content.scm index bb32be4..b53e399 100644 --- a/tests/server-content.scm +++ b/tests/server-content.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,16 +14,19 @@ ;; 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 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-content) + #:use-module (webid-oidc server resource content) + #: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) + #:duplicates (merge-generics) + #:declarative? #t) (with-test-environment "server-content" @@ -34,37 +37,32 @@ (false-if-exception ;; This is the etag of /wtf (delete-file "tests/server-content.home/disfluid/server/content/X/hqM_2Avn5_egTzs")) - (receive (/ /wtf) - (with-session - (lambda (content-type contained static-content create delete) - (let ((/ (create 'text/turtle '("/whatever" "/you" "/want") - "# This is the content of the root")) - (/wtf (create 'text/plain '() "This is the content of the wtf"))) - (unless (equal? (static-content /wtf) - (string->utf8 "This is the content of the wtf")) - (exit 1)) - (delete /wtf) - (unless (eq? (content-type /wtf) 'text/plain) - ;; It has survived in the cache - (exit 2)) - (values / /wtf)))) - (with-session - (lambda (content-type contained static-content create delete) - (unless - (with-exception-handler - (lambda (error) - ;; Good, we can’t load /wtf - #t) - (lambda () - (content-type /wtf) - #f) - #:unwind? #t) - ;;We could read /wtf, it has not been deleted - (exit 3)) - (unless (eq? (content-type /) 'text/turtle) - (exit 4)) - (unless (equal? (contained /) '("/whatever" "/you" "/want")) - (exit 5)) - (unless (equal? (static-content /) - (string->utf8 "# This is the content of the root")) - (exit 6))))))) + (parameterize ((current-content-cache (make <content-cache>))) + (let ((/ + (make <content> + #:content-type 'text/turtle + #:contained '("/whatever" "/you" "/want") + #:static-content "# This is the content of the root")) + (/wtf + (make <content> + #:content-type 'text/plain + #:static-content "This is the content of the wtf"))) + (unless (equal? (static-content /wtf) + (string->utf8 "This is the content of the wtf")) + (exit 1)) + (delete-content /wtf) + ;; Reload it with cache, it should still be available + (set! /wtf (make <content> #:etag (etag /wtf))) + ;; Reload it without session, and it should fail + (parameterize ((current-content-cache #f)) + (when (false-if-exception (make <content> #:etag (etag /wtf))) + (exit 2))) + (unless (eq? (content-type /wtf) 'text/plain) + (exit 3)) + (unless (eq? (content-type /) 'text/turtle) + (exit 4)) + (unless (equal? (contained /) '("/whatever" "/you" "/want")) + (exit 5)) + (unless (equal? (static-content /) + (string->utf8 "# This is the content of the root")) + (exit 6)))))) 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))))))) |