Implement resource modifications as with PUT

2 files changed, 156 insertions, 2 deletions

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)