summaryrefslogtreecommitdiff
path: root/tests/server-path.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tests/server-path.scm')
-rw-r--r--tests/server-path.scm233
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)))))))
generated by cgit v1.2.3 (git 2.44.0) at 2024-06-26 16:54:59 +0000