From abd89b0c18beb6f6d3224cf661c446cbc61fb443 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Fri, 25 Jun 2021 17:24:28 +0200 Subject: Implement resource modifications as with PUT --- src/scm/webid-oidc/server/Makefile.am | 6 +- src/scm/webid-oidc/server/update.scm | 152 ++++++++++++++++++++++++++++++++++ 2 files changed, 156 insertions(+), 2 deletions(-) create mode 100644 src/scm/webid-oidc/server/update.scm (limited to 'src') diff --git a/src/scm/webid-oidc/server/Makefile.am b/src/scm/webid-oidc/server/Makefile.am index f6627e5..371fc3d 100644 --- a/src/scm/webid-oidc/server/Makefile.am +++ b/src/scm/webid-oidc/server/Makefile.am @@ -1,11 +1,13 @@ dist_serverwebidoidcmod_DATA += \ %reldir%/create.scm \ %reldir%/read.scm \ - %reldir%/precondition.scm + %reldir%/precondition.scm \ + %reldir%/update.scm serverwebidoidcgo_DATA += \ %reldir%/create.go \ %reldir%/read.go \ - %reldir%/precondition.go + %reldir%/precondition.go \ + %reldir%/update.go include %reldir%/resource/Makefile.am diff --git a/src/scm/webid-oidc/server/update.scm b/src/scm/webid-oidc/server/update.scm new file mode 100644 index 0000000..715c4ed --- /dev/null +++ b/src/scm/webid-oidc/server/update.scm @@ -0,0 +1,152 @@ +(define-module (webid-oidc server update) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc server resource path) + #:use-module (webid-oidc server resource content) + #:use-module (webid-oidc server precondition) + #:use-module (webid-oidc cache) + #:use-module (webid-oidc fetch) + #:use-module (webid-oidc http-link) + #:use-module (webid-oidc server resource wac) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (webid-oidc rdf-index) + #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:use-module (rdf rdf) + #:use-module (turtle tordf) + #:use-module (turtle fromrdf) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 receive) + #:use-module (ice-9 optargs) + #:use-module (ice-9 iconv) + #:use-module (ice-9 textual-ports) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 threads) + #:use-module (ice-9 hash-table) + #:use-module (rnrs bytevectors) + #:use-module (oop goops) + #:export + ( + + update + + )) + +(define (remove-containment-triples doc-uri content-type content) + (case content-type + ((text/turtle) + #t) + (else + (raise-exception (make-unsupported-media-type content-type)))) + (let ((graph (fetch + doc-uri + #:http-get + (lambda (uri . args) + (values + (build-response #:headers `((content-type ,content-type))) + content))))) + (with-index + graph + (lambda (rdf-match) + (let ((containment-triples + (rdf-match (uri->string doc-uri) + "http://www.w3.org/ns/auth/acl#contains" + #f))) + (let ((blacklist + (alist->hash-table + (map (lambda (t) + (cons t #t)) + containment-triples)))) + (let ((not-blacklisted? + (lambda (t) + (not + (hash-ref blacklist t #f))))) + (let ((final-graph + (filter not-blacklisted? graph))) + (if (null? containment-triples) + content + (rdf->turtle final-graph)))))))))) + +(define* (update server-name owner user path if-match if-none-match + content-type content + #:key + (http-get http-get)) + (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) -- cgit v1.2.3