;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see .
(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"
(lambda ()
(for-each
(lambda (file)
(false-if-exception (delete-file file)))
'(
"tests/server-path.home/disfluid/server/content/6/8OMG_V5x-KmI6TI"
"tests/server-path.home/disfluid/server/content/X/hqM_2Avn5_egTzs"
"tests/server-path.home/disfluid/server/content/a/68pTwiImTWTpjQl"
"tests/server-path.home/disfluid/server/content/5/n1KPgAd3ng4wSqn"
"tests/server-path.home/disfluid/server/content/D/wxU0ogx5rzRrvu2"
"tests/server-path.home/disfluid/server/content/F/BQKBGrtq6U_M0L7"
"tests/server-path.home/disfluid/server/content/N/gnO8RAS9FpPiO5j"
"tests/server-path.home/disfluid/server/content/n/U46BXbknEaLWZpH"
"tests/server-path.home/disfluid/server/content/y/29x0MEOMybxUqDU"
"tests/server-path.home/disfluid/server/content/b/k7RqZevpCHAumba"
"tests/server-path.home/disfluid/server/content/H/y4S5p1BqTEJi-Jb"
"tests/server-path.home/disfluid/server/content/A/fkGTJRCHc-jHk-V"
"tests/server-path.home/disfluid/server/path/b/FkceBVDI7O39t4bFK02Vu0E7OWtjnjDfAXDLKuREbE"
"tests/server-path.home/disfluid/server/path/b/FkceBVDI7O39t4bFK02Vu0E7OWtjnjDfAXDLKuREbE.lock"
"tests/server-path.home/disfluid/server/path/g/pBBL3msK7bpJ_LUp4xDyrB-EZD1EaJgD6xo9ysqy6Q"
"tests/server-path.home/disfluid/server/path/g/pBBL3msK7bpJ_LUp4xDyrB-EZD1EaJgD6xo9ysqy6Q.lock"
"tests/server-path.home/disfluid/server/path/i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE"
"tests/server-path.home/disfluid/server/path/i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE.lock"
"tests/server-path.home/disfluid/server/path/Q/hRrKeOf3iJxfvabWz2CBYAlF_ovDFXqHWcwhhuQhXg"
"tests/server-path.home/disfluid/server/path/Q/hRrKeOf3iJxfvabWz2CBYAlF_ovDFXqHWcwhhuQhXg.lock"
))
(parameterize ((current-content-cache (make )))
(let ((new
(lambda ()
(make
#:content-type 'text/plain
#:static-content "Hello :)")))
(new-acl
(lambda ()
(make
#:content-type 'text/turtle
#:contained '()
#:static-content
"@prefix acl: .
<#authorized> a acl:Authorization;
acl:accessTo ;
acl:mode acl:Read;
acl:agent .
"))))
;; 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)))))))