diff options
Diffstat (limited to 'src/scm/webid-oidc/server/update.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/update.scm | 153 |
1 files changed, 76 insertions, 77 deletions
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) |