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 ++++++++++++++++++++++++++++++++++ tests/crud.scm | 66 ++++++++++++++- 3 files changed, 219 insertions(+), 5 deletions(-) create mode 100644 src/scm/webid-oidc/server/update.scm 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) diff --git a/tests/crud.scm b/tests/crud.scm index 222bcc3..6524cfd 100644 --- a/tests/crud.scm +++ b/tests/crud.scm @@ -1,5 +1,6 @@ (use-modules (webid-oidc server create) (webid-oidc server read) + (webid-oidc server update) (webid-oidc server resource content) (webid-oidc server resource path) (webid-oidc errors) @@ -31,7 +32,13 @@ "n/U46BXbknEaLWZpH" "A/fkGTJRCHc-jHk-V" "a/68pTwiImTWTpjQl" - "H/y4S5p1BqTEJi-Jb")) + "H/y4S5p1BqTEJi-Jb" + "b/k7RqZevpCHAumba" + "y/29x0MEOMybxUqDU" + "5/KVojpXDg0Aob3_v" + "S/9kvZXAg1UQojIal" + "B/JadnRZKhcTKHHZU" + "_/VhVgLvE4J9JwpIP")) (for-each (lambda (f) (false-if-exception @@ -42,7 +49,10 @@ '("L/uhr1159jdGYjIj_tpM6FDiW4rUZDQQKUnT35lhAR-s" "8/jgewChguz6YRPCTBOkx_9CW94iH_X88rP6Os4aM8jg" "n/PQ_3L8lXCsqpz1tkUhsJnVC9rcyqgDD41DnFPIDG1Q" - "i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE")) + "i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE" + "4/Hkcb0hNCFXVdxfiSfpg9D2LPLelSWBw7rM1xyQkI_M" + "1/8Jb3gOzbpL-A0o4MaBd4Iw41W1c0t3fgywwryZ8vBw" + "P/6DoRBgELS5Hrr0E-sQgRsjN-apgr3GsKZpL9K-NMHs")) (let ((server-name (string->uri "https://example.com")) (owner (string->uri "https://alice.databox.me"))) ;; CREATE @@ -180,4 +190,54 @@ (when (null? (rdf-match #f "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" "http://www.w3.org/ns/auth/acl#Authorization")) - (exit 23))))))))) + (exit 23)))))) + (update server-name owner owner "/inbox/.acl" #f '* 'text/turtle "@prefix acl: . +@prefix foaf: . + +<#default> + a acl:Authorization; + acl:accessTo ; + acl:agent ; + acl:mode acl:Read, acl:Write, acl:Control; + acl:default . + +<#public> + a acl:Authorization; + acl:accessTo ; + acl:default ; + acl:agentClass foaf:Agent; + acl:mode acl:Append. +") + (update server-name owner #f "/inbox/test-notifications/welcome" #f '* 'text/plain "Hello :)") + (with-exception-handler + (lambda (error) + ;; The containment triples are not correct + (unless (incorrect-containment-triples? error) + (exit 24))) + (lambda () + (update server-name owner owner "/inbox/" #f #f 'text/turtle "@prefix ldp: . +@prefix rdfs: . + +<> rdfs:comment \"Alice’s inbox, drop your notifications there and I’ll ignore them.\" . +")) + #:unwind? #t + #:unwind-for-type &incorrect-containment-triples) + (let ((exact-content + "@prefix ldp: . +@prefix rdfs: . + +# This is the exact content submitted to the server, however this +# comment will disappear because the server will re-write the turtle +# representation to change the containment triples. + +<> rdfs:comment \"Alice’s inbox, drop your notifications there and I’ll ignore them.\" ; + ldp:contains . +")) + (update server-name owner owner "/inbox/" #f #f 'text/turtle exact-content) + (receive (headers content) + (read server-name owner owner "/inbox/") + (when (bytevector? content) + (set! content (utf8->string content))) + (when (equal? content exact-content) + (exit 25))))))) + -- cgit v1.2.3