Fix copy for file resources.

5 files changed, 127 insertions, 74 deletions

diff --git a/doc/ref/guile/webdav.texi b/doc/ref/guile/webdav.texi
index bf35320d..a495c945 100644
--- a/doc/ref/guile/webdav.texi
+++ b/doc/ref/guile/webdav.texi
@@ -103,11 +103,13 @@ The name of a resource is the local part of a href.
 All direct children of a resource, as a list.
 @end deftp
 
-@deftp {GOOPS method} add-child! (parent <resource>) (child <resource>) [(overwrite? <boolean>)
+@defun add-child! parent child [#:overwrite?] [#:collection?=(is-collection? child)]
 Adds a resource as a child of another resource.
 
-Currently doesn't do anything more, but will eventually call a
-bookkeeping procedure on the two resources.
+Before adding the resource to the parents child set,
+@code{(setup-new-resource! child parent)} is called. If
+@var{collection?} is true, then
+@code{(setup-new-collection! child parent)} is also called.
 
 If @var{overwrite?} is present, then the parent will be checked for a
 child which already has that name, and take action accordingly.
@@ -117,24 +119,34 @@ old one was kept, and @code{'created} if the new resource was added
 without collisions.
 
 If @var{overwrite?} is absent then the method always returns @var{'created}.
-@end deftp
+@end defun
 
-@deftp {GOOPS method} add-resource! (self <resource>) (name <string>) content
+@defun add-resource! resource name content
 Creates a new resource with the given name, and make it a child of
 @var{self}. Setting its initial content to @var{content}.
 
-This method exists alongside @code{add-child!}, due to historical
-reasons (and that @code{add-resource!} is easier to override if custom
-setup code needs to be run.
-
+Calls @code{add-resource!}, so the same book-keeping procedures are called.
 @c TODO Document throw
 @c TODO Document return
-@end deftp
+@end defun
 
-@deftp {GOOPS method} add-collection! (self <resource>) name
+@defun add-collection! resource name
 Similar to @code{add-resource!} but the created resource is instead a collection.
+@end defun
+
+@deftp {GOOPS method} setup-new-resource! (self <resource>) (parent <resource>)
+Book-keeping procedure called by @code{add-resource!} on @emph{all}
+added resources.
+
+Base implementation in a no-op.
 @end deftp
 
+@deftp {GOOPS method} setup-new-collection! (self <resource>) (parent <resource>)
+Book-keeping procedure called by @code{add-resource!} if
+@var{collection?} is true.
+
+Base implementation is a no-op.
+@end deftp
 
 @deftp {GOOPS method} is-collection? resource
 Is the given resource a collection.
diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm
index 97d5c56d..8d96b228 100644
--- a/module/calp/server/webdav.scm
+++ b/module/calp/server/webdav.scm
@@ -414,21 +414,19 @@
                                     headers: '((content-type . (text/plain))))
                                    "One or more parent components of destination are missing")))))
 
-          (let ((copy (copy-resource source-resource
-                                     (case depth
-                                       ((0) #f)
-                                       ((infinity) #t)
-                                       (else (throw 'invalid-request)))
-                                     dest-name)))
-            (case (add-child! destination-parent-resource
-                              copy
-                              overwrite?)
-              ((created)
-               (values (build-response code: 201) ""))
-              ((replaced)
-               (values (build-response code: 204) ""))
-              ((collision)
-               (values (build-response code: 412) ""))))))))))
+          (case (copy-to-location! source-resource destination-parent-resource
+                                   new-name: dest-name
+                                   include-children?: (case depth
+                                                        ((0) #f)
+                                                        ((infinity) #t)
+                                                        (else (throw 'invalid-requeqst)))
+                                   overwrite?: overwrite?)
+            ((created)
+             (values (build-response code: 201) ""))
+            ((replaced)
+             (values (build-response code: 204) ""))
+            ((collision)
+             (values (build-response code: 412) "")))))))))
 
 
 (define (run-delete href request)
diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm
index 0b1d4ace..e7898ff7 100644
--- a/module/calp/webdav/resource/base.scm
+++ b/module/calp/webdav/resource/base.scm
@@ -45,6 +45,9 @@
            remove-property!
 
 
+           setup-new-resource!
+           setup-new-collection!
+
 
 
            live-properties
@@ -57,6 +60,7 @@
            set-content!
 
            copy-resource
+           copy-to-location!
            cleanup-resource
            delete-child!
            move-resource!
@@ -174,7 +178,6 @@
       (display ; Make output atomic
        (call-with-output-string
          (lambda (port)
-           ;; (define o (dereference self))
            (format port "#<~a name=~s"
                    (class-name (class-of self))
                    (name self))
@@ -187,49 +190,78 @@
       (format port "#<~a>" (class-name (class-of self))))))
 
 
-;;; TODO should add-resource! be kept? It would probably be better to merge it
-;;; with add-child!
-
-
-
-;; Possibly change this to a fixed procedure
-(define-method (add-resource! (self <resource>)
-                              (new-name <string>)
-                              content)
+(define (add-resource! self new-name content)
   (if (lookup-resource self (list new-name))
       (throw 'resource-exists)
       (let ((resource (make (class-of self) name: new-name)))
-        (setup-new-resource! resource self)
-        (add-child! self resource)
+        (add-child! self resource collection?: #f)
         (set-content! resource content)
         resource)))
 
-;; Possibly change this to a fixed procedure,
-;; adding a setup method instead
-(define-method (add-collection! (self <resource>) new-name)
+(define (add-collection! self new-name)
   (if (lookup-resource self (list new-name))
       (throw 'resource-exists)
       (let ((resource (make (class-of self) name: new-name)))
-        (add-child! self resource)
+        (add-child! self resource collection?: #t)
         resource)))
 
+(define (initialize-copied-resource! source copy)
+  (for-each (lambda (tag) (set-dead-property! copy tag))
+            (dead-properties source))
+  (set! (displayname* copy)    (displayname* source)
+        (contentlanguage copy) (contentlanguage source))
+  ;; (format (current-error-port) "Setting content! ~s (~s)~%" copy source)
+  (when (content source)
+    (set-content! copy (content source)))
+  ;; resource-cache should never be copied
+  )
+
 (define-method (copy-resource (self <resource>) include-children?)
   (copy-resource self include-children? #f))
 
 (define-method (copy-resource (self <resource>) include-children? new-name)
   (let ((resource (make (class-of self) name: (or new-name (name self)))))
-    (for-each (lambda (tag) (set-dead-property! resource tag))
-              (dead-properties self))
-    (set! (displayname* resource)    (displayname* self)
-          (contentlanguage resource) (contentlanguage self))
-    (set-content! resource (content self))
+    (initialize-copied-resource! self resource)
     (when include-children?
       (for-each (lambda (c) (add-child! resource c))
                 (map (lambda (c) (copy-resource c #t))
                      (children self))))
-    ;; resource-cache should never be copied
     resource))
 
+;; source and target-parent should be resource instances
+;; new-name a string
+;; include-children? and overwrite? booleans
+(define* (copy-to-location! source target-parent
+                            key:
+                            (new-name (name source))
+                            include-children?
+                            overwrite?
+                            )
+  (let ((copy (make (class-of source) name: new-name))
+        ;; Take copy if child list. If we run `cp -r / /c` then;
+        ;; (at least when /c already exists) our child list gets
+        ;; updated, leading to an infinite loop if we use
+        ;; `(children source)` directly below.
+        (children-before (children source)))
+    (let ((status (add-child! target-parent copy
+                              ;; (is-collection? copy) doesn't work for
+                              ;; all types, since it's not quite yet
+                              ;; added (for example: <file-resoure>
+                              ;; checks if the target resource is a
+                              ;; directory on the file system).
+                              collection?: (is-collection? source)
+                              overwrite?: overwrite?)))
+      (case status
+        ((created replaced)
+         (initialize-copied-resource! source copy)
+         (when include-children?
+           (for-each (lambda (c) (copy-to-location!
+                             c copy
+                             include-children?: #t))
+                     children-before))
+         status)
+        ((collision) 'collision)))))
+
 (define (xml-element-hash-key tag)
   "Returns a value suitable as a key to hash-ref (and family)"
   (cons (xml-element-namespace tag)
@@ -364,27 +396,31 @@
 (define-method (setup-new-resource! (this <resource>) (parent <resource>))
   'noop)
 
-(define-method (add-child! (this <resource>) (child <resource>))
-  ;; TODO this should call a method on child, allowing it to be updated
-  ;; with aditional context
-  ;; (prepare-for-add! child this)
+(define-method (setup-new-collection! (this <resource>) (parent <resource>))
+  'noop)
+
+(define (add-child* this child collection?)
+  (setup-new-resource! child this)
+  (when collection?
+    (setup-new-collection! child this))
   (set! (resource-children this)
-    (cons child (resource-children this)))
-  'created)
+    (cons child (resource-children this))))
 
-(define-method (add-child! (this <resource>) (child <resource>) (overwrite? <boolean>))
+(define* (add-child! this child
+                     key:
+                     overwrite?
+                     (collection? (is-collection? child)))
   (let ((existing (lookup-resource this (list (name child)))))
     (cond ((and overwrite? existing)
-           (set! (resource-children this)
-             ;; TODO properly remove the old node, similar to mov DELETE
-             ;; will do it (calling cleanup, and so on).
-             (cons child (delete existing (children this))))
+           (delete-child! this existing)
+           (add-child* this child collection?)
            'replaced)
           (existing 'collision)
           (else
-           (add-child! this child)
+           (add-child* this child collection?)
            'created))))
 
+
 ;; Free any aditional system resources held by this object.
 ;; For example, file resources will remove the underlying file here.
 (define-method (cleanup-resource (this <resource>))
@@ -417,8 +453,9 @@
         ;; [RFC4918] 9.9.3 specifies that the server MUST run a DELETE
         ;; on the target if overwrite is true, but I actually don't
         ;; see the difference between that and a propper move...
-        (let ((status (add-child! dest-parent (copy-resource source #t dest-name)
-                                  overwrite?)))
+        (let ((status (add-child! dest-parent
+                                  (copy-resource source #t dest-name)
+                                  overwrite?: overwrite?)))
           (case status
             ((created replaced)
              (delete-child! from-parent source)
diff --git a/module/calp/webdav/resource/file.scm b/module/calp/webdav/resource/file.scm
index 58e71e2c..e2fec9a5 100644
--- a/module/calp/webdav/resource/file.scm
+++ b/module/calp/webdav/resource/file.scm
@@ -27,6 +27,14 @@
   (root getter: root setter: set-root! init-value: "/" init-keyword: root:)
   (path getter: path setter: set-path! init-value: "/" init-keyword: path:))
 
+(define-method (write (self <file-resource>) port)
+  (display
+   (format #f "#<<file-resource> name=~s, root=~s, path=~s>"
+           (name self)
+           (root self)
+           (path self))
+   port))
+
 (define (file-resource? x)
   (is-a? x <file-resource>))
 
@@ -102,20 +110,16 @@
                          (list data) #f))))
 
 
-;; This is currently ONLY called from add-resource! which creates a
-;; child from the type of the parent.
 (define-method (setup-new-resource! (self <file-resource>)
                                     (parent <file-resource>))
+  (next-method)
   (set-root! self (root parent))
   (set-path! self (path-append (path parent) (name self))))
 
-
-(define-method (add-collection! (self <file-resource>) new-name)
-  (let ((resource (next-method)))
-    (set-root! resource (root self))
-    (set-path! resource (path-append (path self) new-name))
-    (mkdir (path-append (root resource) (path resource)))
-    resource))
+(define-method (setup-new-collection! (self <file-resource>)
+                                      (parent <file-resource>))
+  (next-method)
+  (mkdir (filepath self)))
 
 (define-method (cleanup-resource (self <file-resource>))
   ((if (is-collection? self)
diff --git a/tests/test/webdav-server.scm b/tests/test/webdav-server.scm
index 64a9e144..67747de7 100644
--- a/tests/test/webdav-server.scm
+++ b/tests/test/webdav-server.scm
@@ -264,7 +264,9 @@
   (parameterize ((root-resource (make <virtual-resource> name: "*root*")))
     (add-resource! (root-resource) "a" "Content of A")
     (let ((a (lookup-resource (root-resource) '("a"))))
-      (set-property! a `(,(xml prop-ns 'test) "prop-value")))
+      (set-property! a `(,(xml prop-ns 'test) "prop-value"))
+      ;; Extra child added to ensure deep copy works
+      (add-resource! a "d" "Content of d"))
 
     (test-group "cp /a /c"
       (let ((response _
@@ -309,9 +311,9 @@
         (test-eqv "Check that reported replaced"
           204 (response-code response))
         (test-equal "Check that recursive resources where created"
-          '("/" "/a" "/c"
+          '("/" "/a" "/a/d" "/c"
             ;; New resources. Note that /c/c doesn't create an infinite loop
-            "/c/a" "/c/c")
+            "/c/a" "/c/a/d" "/c/c")
           (map car
            (sort* (map (lambda (p) (cons (href->string (car p)) (cdr p)))
                        (all-resources-under (root-resource) '()))