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 | |
| parent | 668aa5736b2709e15e3ea14381e010c8646a4c38 (diff) | |
Content API: use GOOPS for the cache
| -rw-r--r-- | doc/disfluid.texi | 116 | ||||
| -rw-r--r-- | po/disfluid.pot | 6 | ||||
| -rw-r--r-- | po/fr.po | 6 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/create.scm | 279 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/delete.scm | 53 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/read.scm | 301 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/resource/content.scm | 209 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/resource/path.scm | 129 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/resource/wac.scm | 108 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/update.scm | 153 | ||||
| -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 |
14 files changed, 1108 insertions, 967 deletions
diff --git a/doc/disfluid.texi b/doc/disfluid.texi index 35e8e13..5523a21 100644 --- a/doc/disfluid.texi +++ b/doc/disfluid.texi @@ -1457,42 +1457,67 @@ copy for both. The @emph{content} API is contained in the @code{(webid-oidc server resource content)} module. -@deffn function with-session @var{f} -Call @var{f} with 5 arguments: -@itemize -@item -a function to get the content-type of a given etag; -@item -a function to list the paths contained within the resource; -@item -a function to load the content of a given etag; -@item -a function to create a new content; -@item -a function to remove a content from the file system. It is still -possible to query it with the first 3 functions, but new sessions will -not see it. -@end itemize +@deftp {Class} <content> () @var{etag} @var{content-type} @var{contained} @var{static-content} +This class encapsulate a static resource content linked to a +particular @var{etag}. + +The @var{content-type} is a symbol, and @var{static-content} is a +bytevector, although a string will be encoded to UTF-8 at construction +time. @var{contained} is either @code{#f}, if the resource is not a +container, or a list of resource paths (each one is a string) +identifying contained resources. + +You can construct a content in two ways. + +If you pass @code{#:@var{etag}}, it will be loaded from the file +system under the @var{etag} index, or if @code{#:@var{cache}} is +passed or the @code{current-content-cache} is set to @var{cache}, it +will try to load from @var{cache} first. If you define a cache, the +result will also be added to @var{cache}. + +If you pass @code{#:@var{content-type}}, @code{#:@var{contained}} and +@code{#:@var{static-content}}, but not @code{#:etag}, it will be +created and saved to disk, and optionally added to the +@code{#:@var{cache}} or the current content cache. +@end deftp -Since the contents are read-only, it is possible to cache the value of -the content in memory. This is why @var{f} should run within a session -with memoization. +@deftp {Class} <content-cache> () @var{cache} +Since the contents are read-only, it is possible to cache the values +in memory to avoid reading the same file more than once. This is how +the session works. -Resources only store @emph{static} content, because the membership -triples for containers is considered dynamic and not included in the -representation. +@var{cache} is a hash table for string etag values to cached content +values. It is initialized as an empty hash table. +@end deftp -The first 3 functions as well as the last one are called with an etag, -and the function to create a content is called with the content-type, -list of contained paths, and (static) content. +@deffn {Generic} etag @var{content} +Return the ETag of @var{content}, as a string. +@end deffn + +@deffn {Generic} content-type @var{content} +Return the Content-Type of @var{content}, as a symbol. +@end deffn + +@deffn {Generic} contained @var{content} +Return the contained paths of @var{content}, as a list of strings, or +@code{#f} if it is not a container. +@end deffn + +@deffn {Generic} static-content @var{content} +Return the static content of @var{content}, as a bytevector. +@end deffn -The contents are searched in the @emph{server/content} subdirectory of -@var{data-home}. +@deffn {Generic} delete-content @var{content} +@deffnx {Generic} delete-content @var{etag} +Remove [@var{content}’s] @var{etag} from the file system. If it is +cached in @var{session}, also remove the cached value. Otherwise, +other sessions can still access it. @end deffn -@deffn parameter data-home -Defines the directory where to store persistent data. Defaults to -@emph{XDG_DATA_HOME}. +@deffn parameter current-content-cache +A guile parameter indicating a cache where loaded contents should be +added and preferably fetched. By default, no caching is performed. You +need to set this parameter to benefit from it. @end deffn The @emph{path} API is defined in @@ -1502,10 +1527,10 @@ The @emph{path} API is defined in Read the resource at @var{path}, and return 2 values: @enumerate @item -the ETag of the main resource; +the content of the main resource; @item an alist where keys are auxiliary resource type URIs (the type is from -@code{(web uri)}), and the values are ETags of the corresponding +@code{(web uri)}), and the values are contents of the corresponding resource. @end enumerate @@ -1513,27 +1538,32 @@ If the resource is not found, raise an exception with type @code{&path-not-found}, and maybe @code{&uri-slash-semantics-error} if a resource with a different ending-in-slash exists. +If the @code{current-content-cache} parameter is set to a cache, it +will be used to load the content and auxiliary contents. + This function is safe to call when the path is being modified, either by another thread, process or else, as the returned values will always be consistent. However, once the function returns, an updating process -may have deleted the returned ETags. If this is the case, then you +may have deleted the returned content. If this is the case, then you must call this function again to read the updated path. @end deffn -@deffn function update-path @var{path} @var{f} @var{content-type} @var{contained} @var{static-content} @var{create} @var{delete} [@var{#:create-intermediate-containers?}=@code{#f}] -Read @var{path}, call @var{f} with two values: the ETag and the -auxiliary ETags (as returned by @var{read-path}), and update the path -accordingly. If @var{path} does not exist, then the first argument is -@code{#f} and the second one is the empty list. +@deffn function update-path @var{path} @var{f} [@code{#:@var{create-intermediate-containers?}}=@code{#f}] +Read @var{path}, call @var{f} with two values: the main content and +the auxiliary contents (as returned by @var{read-path}), and update +the path accordingly. If @var{path} does not exist, then the first +argument is @code{#f} and the second one is the empty list. If @var{f} returns @code{#f}, then the resource is deleted. -If @var{f} returns an ETag as the first returned value and an alist of -auxiliary resource ETags as the second value, then the resource is -updated. +If @var{f} returns two values: a content as the first and an alist of +auxiliary types (as URIs) to auxiliary contents as the second, then +the resource is updated. -The last functions are from the content API. Since creating or -deleting children requires updating the parent, we need them. +This function uses the @code{current-content-cache} parameter to load +contents. If a resource is created or deleted, the parent’s +containment triples will be modified, so they will also be loaded in +the cache. Some operations should create the intermediate containers for a given path, this is the case for the @code{PUT} HTTP verb. For @code{POST}, diff --git a/po/disfluid.pot b/po/disfluid.pot index e744e78..e1692ba 100644 --- a/po/disfluid.pot +++ b/po/disfluid.pot @@ -8,7 +8,7 @@ msgid "" msgstr "" "Project-Id-Version: disfluid SNAPSHOT\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-10-04 22:47+0200\n" +"POT-Creation-Date: 2021-10-04 22:50+0200\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n" "Language-Team: LANGUAGE <LL@li.org>\n" @@ -2040,12 +2040,12 @@ msgstr "" msgid "the created resource cannot have containment triples" msgstr "" -#: src/scm/webid-oidc/server/create.scm:146 +#: src/scm/webid-oidc/server/create.scm:147 #, scheme-format msgid "cannot POST to an auxiliary resource path, ~s" msgstr "" -#: src/scm/webid-oidc/server/read.scm:103 +#: src/scm/webid-oidc/server/read.scm:101 #, scheme-format msgid "the auxiliary resource of type ~s at ~s is absent" msgstr "" @@ -2,7 +2,7 @@ msgid "" msgstr "" "Project-Id-Version: webid-oidc 0.0.0\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-10-04 22:47+0200\n" +"POT-Creation-Date: 2021-10-04 22:50+0200\n" "PO-Revision-Date: 2021-09-29 12:42+0200\n" "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n" "Language-Team: French <vivien@planete-kraus.eu>\n" @@ -2416,12 +2416,12 @@ msgstr "seul text/turtle est autorisé comme cible d’une requête POST, pas ~s msgid "the created resource cannot have containment triples" msgstr "la ressource créée ne peut pas avoir de triplets de contention" -#: src/scm/webid-oidc/server/create.scm:146 +#: src/scm/webid-oidc/server/create.scm:147 #, scheme-format msgid "cannot POST to an auxiliary resource path, ~s" msgstr "impossible de POSTer vers un chemin de ressource auxiliaire, ~s" -#: src/scm/webid-oidc/server/read.scm:103 +#: src/scm/webid-oidc/server/read.scm:101 #, scheme-format msgid "the auxiliary resource of type ~s at ~s is absent" msgstr "la ressource auxiliaire de type ~s à ~s est absente" diff --git a/src/scm/webid-oidc/server/create.scm b/src/scm/webid-oidc/server/create.scm index 0558ff3..6c2a619 100644 --- a/src/scm/webid-oidc/server/create.scm +++ b/src/scm/webid-oidc/server/create.scm @@ -119,58 +119,58 @@ (types-indicate-container? (cdr types)))))) (define* (create server-name owner user container types slug content-type content) - (check-acl-can-append server-name container owner user) - (unless (and slug (not (equal? slug ""))) - (set! slug (stubs:random 12))) - (when (string-contains slug "/") - (let ((i (string-contains slug "/"))) - (set! slug (substring slug 0 i)))) - (let ((container? (types-indicate-container? types))) - (let ((doc-uri - (build-uri - (uri-scheme server-name) - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path - (string-append - "/" - (encode-and-join-uri-path - (append (split-and-decode-uri-path container) - (list slug))) - ;; There’s no risk to have // here, because slug is - ;; non-empty. - (if container? "/" ""))))) - (when (auxiliary-path? (uri-path doc-uri)) - (let ((final-message - (format #f (G_ "cannot POST to an auxiliary resource path, ~s") - (uri-path doc-uri)))) - (raise-exception - (make-exception - (make-path-is-auxiliary (uri-path doc-uri)) - (make-exception-with-message final-message))))) - (when container? - (without-containment-triples doc-uri content-type content)) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (catch 'slug-already-exists - (lambda () - (update-path - (uri-path doc-uri) - (lambda (etag auxiliary) - (when etag - (throw 'slug-already-exists)) - (values - (do-create content-type (and container? '()) content) - '())) - load-content-type load-contained load-static-content - do-create do-delete) - doc-uri) - (lambda error - (create server-name owner user container types - (string-append slug "-" (stubs:random 12)) - content-type content)))))))) + (parameterize ((current-content-cache (make <content-cache>))) + (check-acl-can-append server-name container owner user) + (unless (and slug (not (equal? slug ""))) + (set! slug (stubs:random 12))) + (when (string-contains slug "/") + (let ((i (string-contains slug "/"))) + (set! slug (substring slug 0 i)))) + (let ((container? (types-indicate-container? types))) + (let ((doc-uri + (build-uri + (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path + (string-append + "/" + (encode-and-join-uri-path + (append (split-and-decode-uri-path container) + (list slug))) + ;; There’s no risk to have // here, because slug is + ;; non-empty. + (if container? "/" ""))))) + (when (auxiliary-path? (uri-path doc-uri)) + (let ((final-message + (format #f (G_ "cannot POST to an auxiliary resource path, ~s") + (uri-path doc-uri)))) + (raise-exception + (make-exception + (make-path-is-auxiliary (uri-path doc-uri)) + (make-exception-with-message final-message))))) + (when container? + (without-containment-triples doc-uri content-type content)) + (parameterize ((current-content-cache (make <content-cache>))) + (catch 'slug-already-exists + (lambda () + (update-path + (uri-path doc-uri) + (lambda (main auxiliary) + (when main + (throw 'slug-already-exists)) + (values + (make <content> + #:content-type content-type + #:contained (and container? '()) + #:static-content content) + '()))) + doc-uri) + (lambda error + (create server-name owner user container types + (string-append slug "-" (stubs:random 12)) + content-type content)))))))) (define (create-root server-name owner) (define (fix-angle-aux accu chars) @@ -185,29 +185,32 @@ (fix-angle-aux (append next-accu accu) rest))))) (define (fix-angle str) (fix-angle-aux '() (string->list str))) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (catch 'already-exists - (lambda () - (update-path - "/" - (lambda (etag auxiliary) - (when etag - (throw 'already-exists)) - (let ((root-uri - (build-uri - (uri-scheme server-name) - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path "/"))) - (values - (do-create 'text/turtle '() "") - (list - (cons (string->uri "http://www.w3.org/ns/auth/acl#accessControl") - (do-create 'text/turtle #f - (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . + (parameterize ((current-content-cache (make <content-cache>))) + (catch 'already-exists + (lambda () + (update-path + "/" + (lambda (main auxiliary) + (when main + (throw 'already-exists)) + (let ((root-uri + (build-uri + (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path "/"))) + (values + (make <content> + #:content-type 'text/turtle + #:contained '() + #:static-content "") + (list + `(,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") + . ,(make <content> + #:content-type 'text/turtle + #:static-content + (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . <#default> a acl:Authorization; @@ -216,66 +219,68 @@ acl:mode acl:Read, acl:Write, acl:Control; acl:default <~a>. " - (fix-angle (uri->string root-uri)) - (fix-angle (uri->string owner)) - (fix-angle - (uri->string - (build-uri (uri-scheme root-uri) - #:userinfo (uri-userinfo root-uri) - #:host (uri-host root-uri) - #:port (uri-port root-uri) - #:path "/")))))))))) - load-content-type load-contained load-static-content - do-create do-delete) - #t) - (lambda error - #f)) - (when (and (equal? (uri-scheme server-name) - (uri-scheme owner)) - (equal? (uri-userinfo server-name) - (uri-userinfo owner)) - (equal? (uri-host server-name) - (uri-host owner)) - (equal? (uri-port server-name) - (uri-port owner))) - ;; We need to make sure that the profile exists - (catch 'already-exists - (lambda () - (update-path - (uri-path owner) - (lambda (etag auxiliary) - (when etag - (throw 'already-exists)) - (values - (do-create 'text/turtle #f - (format #f "@prefix foaf: <http://xmlns.com/foaf/0.1/> . + (fix-angle (uri->string root-uri)) + (fix-angle (uri->string owner)) + (fix-angle + (uri->string + (build-uri (uri-scheme root-uri) + #:userinfo (uri-userinfo root-uri) + #:host (uri-host root-uri) + #:port (uri-port root-uri) + #:path "/"))))))))))) + #t) + (lambda error + #f)) + (when (and (equal? (uri-scheme server-name) + (uri-scheme owner)) + (equal? (uri-userinfo server-name) + (uri-userinfo owner)) + (equal? (uri-host server-name) + (uri-host owner)) + (equal? (uri-port server-name) + (uri-port owner))) + ;; We need to make sure that the profile exists + (catch 'already-exists + (lambda () + (update-path + (uri-path owner) + (lambda (main auxiliary) + (when main + (throw 'already-exists)) + (values + (make <content> + #:content-type 'text/turtle + #:static-content + (format #f "@prefix foaf: <http://xmlns.com/foaf/0.1/> . @prefix ldp: <http://www.w3.org/ns/ldp#> . <~a~a> a foaf:Person . " - (if (uri-query owner) - (string-append - "?" - (fix-angle - (uri-encode (uri-query owner)))) - "") - (if (uri-fragment owner) - (string-append - "#" - (fix-angle - (uri-encode (uri-fragment owner)))) - ""))) - (list - (cons (string->uri "http://www.w3.org/ns/auth/acl#accessControl") - (let ((doc-uri - (build-uri - (uri-scheme owner) - #:userinfo (uri-userinfo owner) - #:host (uri-host owner) - #:port (uri-port owner) - #:path (uri-path owner)))) - (do-create 'text/turtle #f - (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . + (if (uri-query owner) + (string-append + "?" + (fix-angle + (uri-encode (uri-query owner)))) + "") + (if (uri-fragment owner) + (string-append + "#" + (fix-angle + (uri-encode (uri-fragment owner)))) + ""))) + (list + `(,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") + . ,(let ((doc-uri + (build-uri + (uri-scheme owner) + #:userinfo (uri-userinfo owner) + #:host (uri-host owner) + #:port (uri-port owner) + #:path (uri-path owner)))) + (make <content> + #:content-type 'text/turtle + #:static-content + (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . @prefix foaf: <http://xmlns.com/foaf/0.1/> . <#public> @@ -290,10 +295,8 @@ acl:agent <~a>; acl:mode acl:Read, acl:Write, acl:Control. " - (fix-angle (uri->string doc-uri)) - (fix-angle (uri->string doc-uri)) - (fix-angle (uri->string owner))))))))) - load-content-type load-contained load-static-content - do-create do-delete - #:create-intermediate-containers? #t)) - (lambda error #f)))))) + (fix-angle (uri->string doc-uri)) + (fix-angle (uri->string doc-uri)) + (fix-angle (uri->string owner))))))))) + #:create-intermediate-containers? #t)) + (lambda error #f))))) diff --git a/src/scm/webid-oidc/server/delete.scm b/src/scm/webid-oidc/server/delete.scm index 02344ad..445622c 100644 --- a/src/scm/webid-oidc/server/delete.scm +++ b/src/scm/webid-oidc/server/delete.scm @@ -41,6 +41,7 @@ #:use-module (ice-9 binary-ports) #:use-module (ice-9 threads) #:use-module (ice-9 hash-table) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:declarative? #t @@ -52,30 +53,28 @@ )) (define* (delete server-name owner user path if-match if-none-match) - (check-acl-can-write server-name path owner user) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (receive (base-path path-type) - (base-path path) - (update-path - base-path - (lambda (main-etag auxiliary) - (let ((relevant-etag - (if path-type - (assoc-ref auxiliary path-type) - main-etag))) - (check-precondition path if-match if-none-match relevant-etag) - (if path-type - ;; Delete an auxiliary resource - (values - main-etag - (filter - (lambda (auxiliary) - (not (equal? (car auxiliary) path-type))) - auxiliary)) - ;; Delete the main resource, if it’s not the root and - ;; it’s not a non-empty container (those things are - ;; checked by update-path). - #f))) - load-content-type load-contained load-static-content do-create do-delete))))) + (parameterize ((current-content-cache (make <content-cache>))) + (check-acl-can-write server-name path owner user) + (receive (base-path path-type) + (base-path path) + (update-path + base-path + (lambda (main auxiliary) + (let ((relevant + (if path-type + (assoc-ref auxiliary path-type) + main))) + (check-precondition path if-match if-none-match (and relevant (etag relevant))) + (if path-type + ;; Delete an auxiliary resource + (values + main + (filter + (match-lambda + ((type . content) + (not (equal? type path-type)))) + auxiliary)) + ;; Delete the main resource, if it’s not the root and + ;; it’s not a non-empty container (those things are + ;; checked by update-path). + #f))))))) diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm index 0cd49fd..73d32e3 100644 --- a/src/scm/webid-oidc/server/read.scm +++ b/src/scm/webid-oidc/server/read.scm @@ -65,157 +65,150 @@ (define* (read server-name owner user path) (declare-link-header!) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (check-acl-can-read server-name path owner user) - (receive (base-path path-type) - (base-path path) - (let ((container? (container-path? path)) - (root? (root-path? path)) - (acl? - (equal? path-type - (string->uri - "http://www.w3.org/ns/auth/acl#accessControl"))) - (description? - (equal? - path-type - (string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby")))) - (receive (main-etag auxiliary) - (read-path base-path) - (let ((relevant-etag - (if path-type - (assoc-ref auxiliary path-type) - main-etag)) - (needs-meta? - (case (load-content-type main-etag) - ((text/turtle) - #f) - (else #t))) - (needs-acl? - (not acl?)) - (allow (cond (root? '(GET HEAD OPTIONS POST PUT)) - (container? '(GET HEAD OPTIONS POST PUT DELETE)) - (else '(GET HEAD OPTIONS PUT DELETE))))) - (unless relevant-etag - (let ((final-message - (format #f (G_ "the auxiliary resource of type ~s at ~s is absent") - (uri->string path-type) - (uri->string base-path)))) - (raise-exception - (make-exception - (make-auxiliary-resource-absent base-path path-type) - (make-exception-with-message final-message))))) - (let ((accept-put (if (or container? path-type) - "text/turtle; application/n-quads; application/ld+json" - "*/*"))) - (values - ;; Headers - (let ((links - (let ((type - (cons - (if container? - (string->uri "http://www.w3.org/ns/ldp#BasicContainer") - (string->uri "http://www.w3.org/ns/ldp#Resource")) - '((rel . "type")))) - (acl - (and needs-acl? - (cons - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path (derive-path - base-path - (string->uri - "http://www.w3.org/ns/auth/acl#accessControl"))) - '((rel . "acl"))))) - (describedby - (and needs-meta? - (cons - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path (derive-path - base-path - (string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) - '((rel . "describedby"))))) - (describes - (and description? - (cons - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path base-path) - '((rel . "https://www.w3.org/ns/iana/link-relations/relation#describes"))))) - (storage - (and root? - (list - (list - (string->uri "http://www.w3.org/ns/pim/space#Storage") - '(rel . "type")) - (list - owner - '(rel . "http://www.w3.org/ns/solid/terms#owner")))))) - (append - (list type) - (if acl (list acl) '()) - (if describedby (list describedby) '()) - (if describes (list describes) '()) - (or storage '()))))) - `((link . ,links) - (allow . ,allow) - (accept-put . ,accept-put) - (content-type - . (,(if container? - 'text/turtle - (load-content-type relevant-etag)))) - (etag . (,relevant-etag . #f)))) - ;; Content - (if container? - (let ((static-graph - (parameterize - ((p:anonymous-http-request - (lambda (uri . args) - (values - (build-response - #:headers `((content-type ,(load-content-type relevant-etag)))) - (load-static-content relevant-etag))))) - (fetch - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path))))) - (let ((final-graph - (reverse - (append - (map (lambda (contained-path) - (make-rdf-triple - (uri->string - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path)) - "http://www.w3.org/ns/ldp#contains" - (uri->string - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path contained-path)))) - (load-contained relevant-etag)) - static-graph)))) - (rdf->turtle final-graph))) - (load-static-content relevant-etag))))))))))) + (parameterize ((current-content-cache (make <content-cache>))) + (check-acl-can-read server-name path owner user) + (receive (base-path path-type) + (base-path path) + (let ((container? (container-path? path)) + (root? (root-path? path)) + (acl? + (equal? path-type + (string->uri + "http://www.w3.org/ns/auth/acl#accessControl"))) + (description? + (equal? + path-type + (string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby")))) + (receive (main auxiliary) + (read-path base-path) + (let ((relevant + (if path-type + (assoc-ref auxiliary path-type) + main)) + (needs-meta? + (case (content-type main) + ((text/turtle) + #f) + (else #t))) + (needs-acl? + (not acl?)) + (allow (cond (root? '(GET HEAD OPTIONS POST PUT)) + (container? '(GET HEAD OPTIONS POST PUT DELETE)) + (else '(GET HEAD OPTIONS PUT DELETE))))) + (unless relevant + (let ((final-message + (format #f (G_ "the auxiliary resource of type ~s at ~s is absent") + (uri->string path-type) + (uri->string base-path)))) + (raise-exception + (make-exception + (make-auxiliary-resource-absent base-path path-type) + (make-exception-with-message final-message))))) + (let ((accept-put (if (or container? path-type) + "text/turtle; application/n-quads; application/ld+json" + "*/*"))) + (values + ;; Headers + (let ((links + (let ((type + `(,(string->uri + (string-append "http://www.w3.org/ns/ldp#" + (if container? + "BasicContainer" + "Resource"))) + (rel . "type"))) + (acl + (and needs-acl? + `(,(build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (derive-path + base-path + (string->uri + "http://www.w3.org/ns/auth/acl#accessControl"))) + (rel . "acl")))) + (describedby + (and needs-meta? + `(,(build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (derive-path + base-path + (string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) + (rel . "describedby")))) + (describes + (and needs-meta? + `(,(build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path base-path) + (rel . "https://www.w3.org/ns/iana/link-relations/relation#describes")))) + (storage + (and root? + `((,(string->uri "http://www.w3.org/ns/pim/space#Storage") + (rel . "type")) + (,owner + (rel . "http://www.w3.org/ns/solid/terms#owner")))))) + (append + (list type) + (if acl (list acl) '()) + (if describedby (list describedby) '()) + (if describes (list describes) '()) + (or storage '()))))) + `((link . ,links) + (allow . ,allow) + (accept-put . ,accept-put) + (content-type + . (,(if container? + 'text/turtle + (content-type relevant)))) + (etag . (,(etag relevant) . #f)))) + ;; Content + (if container? + (let ((static-graph + (parameterize + ((p:anonymous-http-request + (lambda (uri . args) + (values + (build-response + #:headers `((content-type ,(content-type relevant)))) + (static-content relevant))))) + (fetch + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path))))) + (let ((final-graph + (reverse + (append + (map (lambda (contained-path) + (make-rdf-triple + (uri->string + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path)) + "http://www.w3.org/ns/ldp#contains" + (uri->string + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path contained-path)))) + (contained relevant)) + static-graph)))) + (rdf->turtle final-graph))) + (static-content relevant)))))))))) diff --git a/src/scm/webid-oidc/server/resource/content.scm b/src/scm/webid-oidc/server/resource/content.scm index 57c51dd..f0d12a5 100644 --- a/src/scm/webid-oidc/server/resource/content.scm +++ b/src/scm/webid-oidc/server/resource/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 @@ -16,6 +16,7 @@ (define-module (webid-oidc server resource content) #:use-module (webid-oidc errors) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) @@ -28,79 +29,165 @@ #:use-module (ice-9 iconv) #:use-module (ice-9 textual-ports) #:use-module (ice-9 binary-ports) - #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) #:use-module (oop goops) + #:declarative? #t #:export ( - with-session + <content> + etag + content-type + contained + static-content + + <content-cache> + cache + delete-content + + current-content-cache )) (define-class <content> () + (etag #:init-keyword #:etag #:getter etag) (content-type #:init-keyword #:content-type #:getter content-type) (contained #:init-keyword #:contained #:getter contained) (static-content #:init-keyword #:static-content #:getter static-content)) -(define (load-content session etag) - (let ((first-char (substring etag 0 1)) - (rest (substring etag 1))) - (call-with-input-file (format #f "~a/server/content/~a/~a" - (p:data-home) - first-char - rest) - (lambda (port) - (let ((properties (read port))) - (set-port-encoding! port "ISO-8859-1") - (let ((ret - (make <content> - #:content-type (assq-ref properties 'content-type) - #:contained (assq-ref properties 'contained) - #:static-content - (string->bytevector (get-string-all port) "ISO-8859-1")))) - (hash-set! session etag ret) - ret)))))) - -(define (new-content session content-type contained static-content) - (when (string? static-content) - (set! static-content (string->utf8 static-content))) - (let ((etag (stubs:random 12))) - (let ((first-char (substring etag 0 1)) - (rest (substring etag 1))) - (stubs:mkdir-p (format #f "~a/server/content/~a" (p:data-home) first-char)) - (let ((port (open (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest) - (logior O_WRONLY O_CREAT O_EXCL)))) - (write `((content-type . ,content-type) - (contained . ,contained)) port) - (set-port-encoding! port "ISO-8859-1") - (display (bytevector->string static-content "ISO-8859-1") port) - (close-port port) - (hash-set! session - etag - (make <content> - #:content-type content-type - #:contained contained - #:static-content static-content)) - etag)))) - -(define (delete-content etag) +(define-class <content-cache> () + (cache #:init-thunk make-hash-table #:getter cache)) + +(define current-content-cache + (make-parameter #f)) + +(define (filter-keyword check arguments) + (let scan ((arguments arguments) + (kept '())) + (match arguments + (() + (let reverse ((reversed kept) + (final '())) + (match reversed + (() final) + ((key value reversed ...) + (reverse reversed `(,key ,value ,@final)))))) + (((? check key) value arguments ...) + (scan arguments `(,key ,value ,@kept))) + ((_ _ arguments ...) + (scan arguments kept))))) + +(define-method (initialize (content <content>) initargs) + (let-keywords + initargs #t + ((etag #f) + (content-type #f) + (contained #f) + (static-content #f) + (cache (current-content-cache)) + (save-to-cache (current-content-cache))) + (cond + ((and (not (eq? content-type 'text/turtle)) + (list? contained)) + ;; Error: containers must be RDF + (fail (G_ "content with contained resources must be RDF"))) + ((and etag content-type static-content) + ;; Construct it the normal way + (unless (string? etag) + (scm-error 'wrong-type-arg "make" + (G_ "#:etag should be a string") + '() + (list etag))) + (unless (symbol? content-type) + (scm-error 'wrong-type-arg "make" + (G_ "#:content-type should be a symbol") + '() + (list content-type))) + (unless (or (not contained) + (list? contained)) + (scm-error 'wrong-type-arg "make" + (G_ "#:contained should be a list if not #f") + '() + (list contained))) + (when (string? static-content) + (set! static-content (string->utf8 static-content))) + (unless (bytevector? static-content) + (scm-error 'wrong-type-arg "make" + (G_ "#:static-content should be a bytevector") + '() + (list static-content))) + (slot-set! content 'etag etag) + (slot-set! content 'content-type content-type) + (slot-set! content 'contained contained) + (slot-set! content 'static-content static-content) + (when save-to-cache + (hash-set! (slot-ref save-to-cache 'cache) etag content))) + ((and cache etag) + ;; Load the content from disk or from the session + (let ((cached (hash-ref (slot-ref save-to-cache 'cache) etag))) + (if cached + (initialize content `(#:etag ,etag + #:content-type ,(slot-ref cached 'content-type) + #:contained ,(slot-ref cached 'contained) + #:static-content ,(slot-ref cached 'static-content) + ,@initargs)) + ;; The cache is useless, try again without it + (parameterize ((current-content-cache #f)) + (initialize + content + `(#:save-to-cache ,cache + ,@(filter-keyword (lambda (key) (not (equal? key #:cache))) + initargs))))))) + (etag + (let ((first-char (substring etag 0 1)) + (rest (substring etag 1))) + (call-with-input-file (format #f "~a/server/content/~a/~a" + (p:data-home) + first-char + rest) + (lambda (port) + (let ((properties (read port))) + (set-port-encoding! port "ISO-8859-1") + (initialize + content + `(#:etag ,etag + #:content-type ,(assq-ref properties 'content-type) + #:contained ,(assq-ref properties 'contained) + #:static-content + ,(string->bytevector (get-string-all port) "ISO-8859-1") + ,@initargs))))))) + ((and content-type static-content) + ;; Save it to disk and generate an ETag + (let ((etag (stubs:random 12))) + ;; Recursive call before touching the file system, so if + ;; there’s an error we won’t create garbage + (initialize content `(#:etag ,etag ,@initargs)) + ;; static-content may be a string converted to bytevector by + ;; the recursive call + (set! static-content (slot-ref content 'static-content)) + (let ((first-char (substring etag 0 1)) + (rest (substring etag 1))) + (stubs:mkdir-p (format #f "~a/server/content/~a" (p:data-home) first-char)) + (let ((port (open (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest) + (logior O_WRONLY O_CREAT O_EXCL)))) + (write `((content-type . ,content-type) + (contained . ,contained)) port) + (set-port-encoding! port "ISO-8859-1") + (display (bytevector->string static-content "ISO-8859-1") port) + (close-port port) + (when save-to-cache + (hash-set! (slot-ref save-to-cache 'cache) etag content)))))) + (else + (fail (G_ "not enough arguments to create or load a <content>")))))) + +(define (delete-etag etag) (let ((first-char (substring etag 0 1)) (rest (substring etag 1))) (delete-file (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest)))) -(define (with-session f) - (let ((session (make-hash-table))) - (define (do-load etag) - (or (hash-ref session etag) - (load-content session etag))) - (define (get-content-type etag) - (content-type (do-load etag))) - (define (get-contained etag) - (contained (do-load etag))) - (define (get-static-content etag) - (static-content (do-load etag))) - (define (do-create content-type contained static-content) - (new-content session content-type contained static-content)) - (define (do-delete etag) - (delete-content etag)) - (f get-content-type get-contained get-static-content do-create do-delete))) +(define-method (delete-content (content <content>)) + (delete-etag (etag content))) + +(define-method (delete-content (etag <string>)) + (delete-etag etag)) diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm index b8a9472..667dd2f 100644 --- a/src/scm/webid-oidc/server/resource/path.scm +++ b/src/scm/webid-oidc/server/resource/path.scm @@ -19,6 +19,7 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc server resource content) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) @@ -30,7 +31,9 @@ #:use-module (ice-9 textual-ports) #:use-module (ice-9 binary-ports) #:use-module (ice-9 threads) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-26) #:use-module (oop goops) #:declarative? #t #:export @@ -167,16 +170,16 @@ (lambda () (call-with-input-file h (lambda (port) - (let ((main-etag (read port))) - (let ((auxiliary (read port))) - (values main-etag - (map (lambda (cell) - (let ((key (string->uri (car cell))) - (value (cdr cell))) - (cons key value))) - auxiliary)))))))))) + (let* ((main-etag (read port)) + (auxiliary (read port))) + (values (make <content> #:etag main-etag) + (map + (match-lambda + (((= string->uri key) . etag) + `(,key . ,(make <content> #:etag etag)))) + auxiliary))))))))) -(define* (update-path path f content-type contained static-content create delete +(define* (update-path path f #:key (create-intermediate-containers? #f)) (let ((h (hash-path path)) (lock (lock-file-name path)) @@ -202,7 +205,7 @@ h lock (lambda (port) - (receive (etag auxiliary) + (receive (main auxiliary) (with-exception-handler (lambda (error) (unless (path-not-found? error) @@ -213,25 +216,21 @@ (read-path path)) #:unwind? #t #:unwind-for-type &path-not-found) - (when etag - (hash-set! garbage etag #t)) - (when auxiliary - (for-each - (lambda (cell) - (when (cdr cell) - (hash-set! garbage (cdr cell) #t))) - auxiliary)) + (when main + (hash-set! garbage (etag main) #t)) + (for-each + (match-lambda + ((_ . content) + (hash-set! garbage (etag content) #t))) + (or auxiliary '())) (call-with-values (lambda () - (f etag auxiliary)) - (case-lambda - ((false) - (when false - (fail (G_ "You’re using the API wrong."))) - ;; Delete the resource - (unless (or (not etag) - (not (contained etag)) - (null? (contained etag))) + (f main auxiliary)) + (match-lambda* + ((#f) + (unless (or (not main) + (not (contained main)) + (null? (contained main))) (raise-exception (make-exception (make-container-not-empty path) @@ -246,62 +245,64 @@ (format #f (G_ "you cannot delete the root")))))) (set! has-been-deleted? #t) #f) - ((new-etag new-auxiliary) - (unless (and (string? new-etag) (list? new-auxiliary)) - (fail (G_ "You’re using the API wrong."))) - (hash-remove! garbage new-etag) - (when new-auxiliary - (for-each - (lambda (cell) - (hash-remove! garbage (cdr cell))) - new-auxiliary)) - (write new-etag port) - (write (map (lambda (cell) - (cons (uri->string (car cell)) - (cdr cell))) - new-auxiliary) + (((? (cute is-a? <> <content>) new-main) + new-auxiliary) + (hash-remove! garbage (etag new-main)) + (for-each + (match-lambda + ((_ . content) + (hash-remove! garbage (etag content)))) + (or new-auxiliary '())) + (write (etag new-main) port) + (write (map (match-lambda + (((= uri->string key) . (= etag etag)) + `(,key . ,etag))) + (or new-auxiliary '())) port) - #t)))))) + #t) + (else + (fail (G_ "you must return either #f to delete the path, or a new main content and alist from URI types to auxiliary content")))))))) (when (and parent-path has-been-created? (not has-been-deleted?)) (update-path parent-path - (lambda (etag auxiliary) + (lambda (main auxiliary) ;; Add path as a child of the resource at etag (unless create-intermediate-containers? - (unless etag + (unless main ;; Typically, POST to a non-existing path (raise-exception (make-path-not-found parent-path)))) (unless auxiliary (set! auxiliary '())) - (let ((content-type (if etag (content-type etag) 'text/turtle)) - (other-children (if etag (contained etag) '())) - (static-content (if etag (static-content etag) (string->utf8 "")))) - (let ((new-etag - (create content-type (cons path other-children) static-content))) - (values new-etag auxiliary)))) - content-type contained static-content create delete + (let ((content-type (if main (content-type main) 'text/turtle)) + (other-children (if main (contained main) '())) + (static-content (if main (static-content main) (string->utf8 "")))) + (let ((new-content + (make <content> + #:content-type content-type + #:contained (cons path other-children) + #:static-content static-content))) + (values new-content auxiliary)))) #:create-intermediate-containers? create-intermediate-containers?)) (when (and parent-path has-been-deleted? (not has-been-created?)) (update-path parent-path - (lambda (etag auxiliary) - (unless etag + (lambda (main auxiliary) + (unless main (raise-exception (make-path-not-found parent-path))) - (let ((content-type (content-type etag)) - (all-children (contained etag)) - (static-content (static-content etag))) + (let ((content-type (content-type main)) + (all-children (contained main)) + (static-content (static-content main))) (values - (create content-type - (filter (lambda (x) - (not (equal? x path))) - all-children) - static-content) + (make <content> + #:content-type content-type + #:contained + (filter (lambda (x) (not (equal? x path))) all-children) + #:static-content static-content) auxiliary))) - content-type contained static-content create delete #:create-intermediate-containers? create-intermediate-containers?)) (for-each - delete - (hash-map->list (lambda (garbage false) garbage) garbage)))) + delete-content + (hash-map->list (lambda (garbage _) garbage) garbage)))) (define (base-path path) (define (check-suffix suffix type) diff --git a/src/scm/webid-oidc/server/resource/wac.scm b/src/scm/webid-oidc/server/resource/wac.scm index d3f4adf..fd0d81e 100644 --- a/src/scm/webid-oidc/server/resource/wac.scm +++ b/src/scm/webid-oidc/server/resource/wac.scm @@ -242,61 +242,59 @@ (define acl-aux (string->uri "http://www.w3.org/ns/auth/acl#accessControl")) (define (wac-get-modes server-name final-path user) - (with-session - (lambda (content-type contained static-content create delete) - (define (wac-check-recursive path check-default?) - (receive (main-etag auxiliary) - (with-exception-handler - (lambda (error) - (unless (path-not-found? error) - (raise-exception error)) - (values #f '())) - (lambda () - (read-path path)) - #:unwind? #t - #:unwind-for-type &path-not-found) - (let ((acl-etag (assoc-ref auxiliary acl-aux))) - (if acl-etag - (with-rdf-source - server-name path (content-type acl-etag) (static-content acl-etag) - (lambda (rdf-match) - (check-authorizations - path check-default? server-name final-path user rdf-match - '() - (map rdf-triple-subject - (rdf-match #f - "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" - "http://www.w3.org/ns/auth/acl#Authorization"))))) - ;; No existing ACL. - (let ((parent-path - (string-append - "/" - (encode-and-join-uri-path - (reverse - (cdr - (reverse - (split-and-decode-uri-path path))))) - "/"))) - (when (equal? parent-path "//") - ;; The parent is the root - (set! parent-path "/")) - (wac-check-recursive parent-path #t)))))) - (let ((all-modes (wac-check-recursive final-path #f))) - (define (accumulate-unique accumulated list) - (cond - ((null? list) - (reverse accumulated)) - ((or (null? accumulated) (not (equal? (car accumulated) (car list)))) - (accumulate-unique (cons (car list) accumulated) (cdr list))) - (else - (accumulate-unique accumulated (cdr list))))) - (accumulate-unique - '() - (sort all-modes - (match-lambda* - (((? uri? (= uri->string a)) - (? uri? (= uri->string b))) - (string< a b))))))))) + (define (wac-check-recursive path check-default?) + (receive (main auxiliary) + (with-exception-handler + (lambda (error) + (unless (path-not-found? error) + (raise-exception error)) + (values #f '())) + (lambda () + (read-path path)) + #:unwind? #t + #:unwind-for-type &path-not-found) + (let ((acl (assoc-ref auxiliary acl-aux))) + (if acl + (with-rdf-source + server-name path (content-type acl) (static-content acl) + (lambda (rdf-match) + (check-authorizations + path check-default? server-name final-path user rdf-match + '() + (map rdf-triple-subject + (rdf-match #f + "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" + "http://www.w3.org/ns/auth/acl#Authorization"))))) + ;; No existing ACL. + (let ((parent-path + (string-append + "/" + (encode-and-join-uri-path + (reverse + (cdr + (reverse + (split-and-decode-uri-path path))))) + "/"))) + (when (equal? parent-path "//") + ;; The parent is the root + (set! parent-path "/")) + (wac-check-recursive parent-path #t)))))) + (let ((all-modes (wac-check-recursive final-path #f))) + (let accumulate-unique ((accumulated '()) + (list (sort all-modes + (match-lambda* + (((? uri? (= uri->string a)) + (? uri? (= uri->string b))) + (string< a b)))))) + (match list + (() (reverse accumulated)) + ((hd list ...) + (match accumulated + ((or () ;; Nothing accumulated, can’t be unique + ((? (lambda (head) (not (equal? head hd)))) _ ...)) + (accumulate-unique `(,hd ,@accumulated) list)) + (else + (accumulate-unique accumulated list)))))))) (define (check-mode server-name path owner user expected-mode) (unless (equal? owner user) diff --git a/src/scm/webid-oidc/server/update.scm b/src/scm/webid-oidc/server/update.scm index d568d06..9bca2e6 100644 --- a/src/scm/webid-oidc/server/update.scm +++ b/src/scm/webid-oidc/server/update.scm @@ -42,6 +42,7 @@ #:use-module (ice-9 binary-ports) #:use-module (ice-9 threads) #:use-module (ice-9 hash-table) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:declarative? #t @@ -92,80 +93,78 @@ (define* (update server-name owner user path if-match if-none-match content-type content) - (define updated-etag #f) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (receive (base-path path-type) - (base-path path) - (update-path - base-path - (lambda (main-etag auxiliary) - (let ((relevant-etag - (if path-type - (assoc-ref auxiliary path-type) - main-etag))) - (if relevant-etag - ;; The resource exists, so we need write permission - (check-acl-can-write server-name path owner user) - ;; The resource does not exist yet, so we only need - ;; append permission - (check-acl-can-append server-name path owner user)) - (check-precondition path if-match if-none-match relevant-etag) - (set! updated-etag - (do-create content-type - (if relevant-etag - (load-contained relevant-etag) - (if (container-path? path) - '() - #f)) - (if (container-path? path) - (remove-containment-triples - (build-uri (uri-scheme server-name) - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path) - content-type content) - content))) - (let ((new-main-etag - (if path-type - main-etag - updated-etag)) - (new-auxiliary - (if path-type - (cons - `(,path-type . ,updated-etag) - (filter - (lambda (auxiliary) - (let ((needs-description? (not (eq? content-type 'text/turtle))) - (is-describedby? - (equal? - (car auxiliary) - (string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) - (is-path-type? - (equal? (car auxiliary) path-type))) - (and (not is-path-type?) - (or (not is-describedby?) needs-description?)))) - (or auxiliary '()))) - (if (eq? content-type 'text/turtle) - (or auxiliary '()) - (cons - `(,(string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby") - . ,(do-create 'text/turtle #f "")) - (or auxiliary '())))))) - (unless new-main-etag - ;; Trying to update an auxiliary resource for a - ;; resource that does not exist - (set! new-main-etag - (do-create 'text/turtle - (if (container-path? path) - '() - #f) - ""))) - (values new-main-etag new-auxiliary)))) - load-content-type load-contained load-static-content do-create do-delete - #:create-intermediate-containers? #t)))) - updated-etag) + (define updated #f) + (parameterize ((current-content-cache (make <content-cache>))) + (receive (base-path path-type) + (base-path path) + (update-path + base-path + (lambda (main auxiliary) + (let ((relevant + (if path-type + (assoc-ref auxiliary path-type) + main))) + (if relevant + ;; The resource exists, so we need write permission + (check-acl-can-write server-name path owner user) + ;; The resource does not exist yet, so we only need + ;; append permission + (check-acl-can-append server-name path owner user)) + (check-precondition path if-match if-none-match (and relevant (etag relevant))) + (set! updated + (make <content> + #:content-type content-type + #:contained + (if relevant + (contained relevant) + (if (container-path? path) + '() + #f)) + #:static-content + (if (container-path? path) + (remove-containment-triples + (build-uri (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path) + content-type content) + content))) + (let ((new-main + (if path-type main updated)) + (new-auxiliary + (if path-type + `((,path-type . ,updated) + ,@(filter + (match-lambda + ((type . content) + (let ((needs-description? (not (eq? content-type 'text/turtle))) + (is-describedby? + (equal? + type + (string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) + (is-path-type? + (equal? type path-type))) + (and (not is-path-type?) + (or (not is-describedby?) needs-description?))))) + (or auxiliary '()))) + (if (eq? content-type 'text/turtle) + (or auxiliary '()) + `((,(string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby") + . ,(make <content> + #:content-type 'text/turtle + #:static-content "")) + ,@(or auxiliary '())))))) + (unless new-main + ;; Trying to update an auxiliary resource for a + ;; resource that does not exist + (set! new-main + (make <content> + #:content-type 'text/turtle + #:contained (and (container-path? path) '()) + #:statitc-content ""))) + (values new-main new-auxiliary)))) + #:create-intermediate-containers? #t))) + updated) 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))))))) |