Fix webdav move.

2 files changed, 45 insertions, 56 deletions

diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm
index 8d96b228..ed9fd9b8 100644
--- a/module/calp/server/webdav.scm
+++ b/module/calp/server/webdav.scm
@@ -445,30 +445,38 @@
            (values (build-response code: 404) "")))))
 
 
-;;; TODO read spec
 (define (run-move href request)
   ;; TODO href="/"
-  ;; (format (current-error-port)
-  ;;         "MOVE ~s: ~s~%" href request)
-  (catch*
-   (lambda ()
-    (let ((to (-> (request-headers request)
-                  (assoc-ref 'destination)
-                  uri-path
-                  string->href))
-          (overwrite? (cond ((assoc 'overwrite request) => cdr)
-                            (else #t))))
-      (case (move-resource! (root-resource) href to overwrite?)
-        ((created)   (values (build-response code: 201) ""))
-        ((replaced)  (values (build-response code: 204) ""))
-        ((collision) (values (build-response code: 412
-                                             headers: '((content-type . (text/plain))))
-                             "Something already exists there")))
-      ))
-   (source-not-found
-    (lambda _ (values (build-response code: 404))))
-   (target-parent-not-found
-    (lambda _ (values (build-response code: 409))))))
+  (define headers (request-headers request))
+  (call/ec
+   (lambda (return)
+     (define-values (path name) (init+last href))
+     (define parent (or (lookup-resource (root-resource) path)
+                        (return (build-response code: 404)
+                                "Source Parent not found")))
+     (define child (or (lookup-resource parent (list name))
+                       (return (build-response code: 404)
+                               "Source not found")))
+     (define-values (dest-path dest-name)
+       (-> headers (assoc-ref 'destination)
+           uri-path string->href init+last))
+     (define dest-parent (or (lookup-resource (root-resource) dest-path)
+                             (return (build-response code: 404)
+                                     "Dest Parent not found")))
+     (define overwrite? (cond ((assoc 'overwrite headers) => cdr)
+                              (else #t)))
+     (define status (move-to-location! parent child
+                                       dest-parent
+                                       new-name: dest-name
+                                       overwrite?: overwrite?))
+
+     (case status
+       ((created)
+        (values (build-response code: 201) ""))
+       ((replaced)
+        (values (build-response code: 204) ""))
+       ((collision)
+        (values (build-response code: 412) ""))))))
 
 
 
@@ -476,9 +484,6 @@
 
 
 
-
-
-
 (define log-table (make-parameter #f))
 (define (init-log-table!) (log-table '()))
 (define (log-table-add! . args)
diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm
index e7898ff7..5f308cc7 100644
--- a/module/calp/webdav/resource/base.scm
+++ b/module/calp/webdav/resource/base.scm
@@ -61,9 +61,9 @@
 
            copy-resource
            copy-to-location!
+           move-to-location!
            cleanup-resource
            delete-child!
-           move-resource!
            setup-new-resource!
            ;; prepare-for-add!
 
@@ -262,6 +262,20 @@
          status)
         ((collision) 'collision)))))
 
+(define* (move-to-location! source-parent source target-parent
+                            key:
+                            (new-name (name source))
+                            overwrite?)
+  (let ((status (copy-to-location! source target-parent
+                                   new-name: new-name
+                                   include-children?: #t
+                                   overwrite?: overwrite?)))
+    (case status
+      ((created replaced)
+       (delete-child! source-parent source)
+       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)
@@ -434,36 +448,6 @@
             (children child))
   (cleanup-resource child))
 
-
-(define-method (move-resource! (root <resource>)
-                               from to
-                               (overwrite? <boolean>))
-  (let* ((dest-path dest-name (init+last to))
-         (from-path from-name (init+last from))
-         (dest-parent (or (lookup-resource root dest-path)
-                          (throw 'target-parent-not-found)))
-         (from-parent (or (lookup-resource root from-path)
-                          (throw 'source-not-found)))
-         (source (or (lookup-resource from-parent (list from-name))
-                     (throw 'source-not-found))))
-    (if (and (is-collection? source)
-             (not overwrite?))
-        'collision
-        ;; run move by running a  copy followed by a delete.
-        ;; [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?: overwrite?)))
-          (case status
-            ((created replaced)
-             (delete-child! from-parent source)
-             status)
-            (else status))))))
-
-
-
 
 
 ;;; TODO rename to simply @code{collection?}