Implement resource modifications as with PUT

3 files changed, 219 insertions, 5 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)
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: <http://www.w3.org/ns/auth/acl#> .
+@prefix foaf: <http://xmlns.com/foaf/0.1/> .
+
+<#default>
+  a acl:Authorization;
+  acl:accessTo <https://example.com/inbox/>;
+  acl:agent <https://alice.databox.me/profile/card#me>;
+  acl:mode acl:Read, acl:Write, acl:Control;
+  acl:default <https://example.com/inbox/>.
+
+<#public>
+  a acl:Authorization;
+  acl:accessTo <https://example.com/inbox/>;
+  acl:default <https://example.com/inbox/>;
+  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: <http://www.w3.org/ns/ldp#> .
+@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .
+
+<> 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: <http://www.w3.org/ns/ldp#> .
+@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .
+
+# 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 <test-notifications> .
+"))
+       (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)))))))
+