1 files changed, 101 insertions, 0 deletions
diff --git a/ldp/resource/update.scm b/ldp/resource/update.scm
new file mode 100644
index 0000000..23f8867
--- /dev/null
+++ b/ldp/resource/update.scm
@@ -0,0 +1,101 @@
+(define-module (ldp resource update)
+  #:use-module (ldp etag)
+  #:use-module (ldp path)
+  #:use-module (ldp resource)
+  #:use-module (ldp http-link)
+  #:use-module (ldp precondition)
+  #:use-module (ldp resource unsafe save)
+  #:use-module (ice-9 threads)
+  #:use-module (web uri)
+  #:use-module ((ldp resource unsafe update) #:prefix unsafe:))
+
+;; FIXME: use a bag of locks, so that we can have concurrent updates
+;; of different resources.
+(define lock (make-mutex))
+
+(define-public (initialize-root)
+  (with-mutex lock
+    (unsafe:initialize-root)))
+
+(define-public (delete path precondition)
+  (with-mutex lock
+    (unsafe:delete path precondition)))
+
+(define (links-hint-for-a-container link-header)
+  (define (has-rel-type properties)
+    (if (null? properties)
+	#f
+	(let* ((prop (car properties))
+	       (key (car prop))
+	       (value (cdr prop)))
+	  (if (and (string=? key "rel")
+		   (or (string=? value "type")
+		       (string=? value "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")))
+	      #t
+	      (has-rel-type (cdr properties))))))
+  (and link-header
+       (let ((links (string->links link-header)))
+	 (let ((for-basic-container
+		(or
+		 (assoc-ref links
+			    (string->uri
+			     "http://www.w3.org/ns/ldp/BasicContainer"))
+		 '()))
+	       (for-container
+		(or
+		 (assoc-ref links
+			    (string->uri
+			     "http://www.w3.org/ns/ldp/Container"))
+		 '())))
+	   (has-rel-type (append for-basic-container for-container))))))
+
+(define-public (post path slug precondition
+		     http-link-header content-type content)
+  (catch 'child-already-exists
+    (lambda ()
+      (let ((child-path (path-cons path slug)))
+	(let ((new-resource
+	       (make-resource
+		child-path
+		(generate-etag)
+		content-type
+		(and (links-hint-for-a-container http-link-header)
+		     '()))))
+	  (with-mutex lock
+	    (unsafe:mkcont-recursive path)
+	    (unsafe:change-contained path precondition
+				     (list child-path)
+				     '())
+	    (save new-resource content)
+	    new-resource))))
+    (lambda err
+      (post path (string-append slug "-" (generate-etag))
+	    precondition
+	    http-link-header content-type content))))
+
+(define-public (put path precondition
+		    http-link-header content-type content)
+  (let ((new-resource
+	 (make-resource
+	  path
+	  (generate-etag)
+	  content-type
+	  (and (links-hint-for-a-container http-link-header)
+	       '()))))
+    (with-mutex lock
+      (if (is-root? path)
+	  (unsafe:initialize-root)
+	  (unsafe:mkcont-recursive (path-parent path)))
+      (catch 'not-found
+	(lambda ()
+	  (unsafe:change-representation path precondition
+					content-type content))
+	(lambda error
+	  ;; path is not the root, because it exists from the
+	  ;; beginning of the locked section
+	  (unsafe:change-contained (path-parent path)
+				   (make-precondition #f #f)
+				   (list path)
+				   '())
+	  (save new-resource content)
+	  new-resource)))))