1 files changed, 92 insertions, 0 deletions
diff --git a/ldp/resource/unsafe/save.scm b/ldp/resource/unsafe/save.scm
new file mode 100644
index 0000000..7510f82
--- /dev/null
+++ b/ldp/resource/unsafe/save.scm
@@ -0,0 +1,92 @@
+(define-module (ldp resource unsafe save)
+  #:use-module (ldp resource)
+  #:use-module (ldp path)
+  #:use-module (ldp resource xml)
+  #:use-module (ice-9 ftw)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (web uri))
+
+(define (clean-directories path kept)
+  ;; Remove everything in path except kept
+  (define (enter-aux? x list)
+    (cond ((null? list)
+	   #t)
+	  ((string=? x (car list))
+	   #f)
+	  (else (enter-aux? x (cdr list)))))
+  (define (enter? name stat result)
+    (enter-aux? name kept))
+  (define (leaf name stat result)
+    (delete-file name)
+    result)
+  (define (down name stat result)
+    result)
+  (define (up name stat result)
+    (unless (string=? name path)
+      (rmdir name))
+    result)
+  (define (skip name stat result) #f)
+  (define (error name stat errno result)
+    (unless (string=? name path)
+      (catch #t
+	(lambda ()
+	  (delete-file name))
+	(lambda err #t))
+      (catch #t
+	(lambda ()
+	  (rmdir name))
+	(lambda err #t)))
+    result)
+  (file-system-fold enter? leaf down up skip error #t path))
+
+(define (fix-directories resource)
+  (let ((dirname (path->filename (resource-path resource))))
+    (map
+     (lambda (path)
+       (catch #t
+	 (lambda ()
+	   ;; It may already exist, of course
+	   (mkdir (path->filename path)))
+	 (lambda err #t)))
+     (or (resource-contained resource) '()))
+    (clean-directories
+     dirname
+     (cons (string-append dirname "/representation")
+	   (map path->filename
+		(or (resource-contained resource) '()))))))
+
+(define-public (save-manifest resource)
+  (let* ((dirname (path->filename (resource-path resource)))
+	 (filename (string-append dirname "/representation/manifest.xml"))
+	 (temp-filename (string-append filename "~")))
+    (catch #t
+      (lambda ()
+	(mkdir (string-append dirname "/representation")))
+      (lambda err #t))
+    (call-with-output-file temp-filename
+      (lambda (port)
+	(resource->xml resource port)))
+    (rename-file temp-filename filename)
+    (fix-directories resource)))
+
+(define-public (save resource content)
+  (let* ((dirname (path->filename (resource-path resource)))
+	 (reprname (string-append dirname "/representation"))
+	 (temp-reprname (string-append dirname "/representation~")))
+    (catch #t
+      (lambda ()
+	(mkdir temp-reprname))
+      (lambda err #t))
+    (call-with-output-file (string-append temp-reprname "/manifest.xml")
+      (lambda (port)
+	(resource->xml resource port)))
+    (call-with-output-file (string-append temp-reprname "/content")
+      (lambda (port)
+	(put-bytevector port
+			(if (string? content)
+			    (string->utf8 content)
+			    content)))
+      #:binary #t)
+    (rename-file temp-reprname reprname)
+    (fix-directories resource)))