diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-12 11:20:27 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-12 12:11:06 +0200 |
commit | 5483072b0fde84eb59b77a4e44135269a51889f6 (patch) | |
tree | 3a86b23414b97f2a7478d02e1cd10551c3ef9d74 | |
parent | UNFINISHED webdav server. (diff) | |
download | calp-5483072b0fde84eb59b77a4e44135269a51889f6.tar.gz calp-5483072b0fde84eb59b77a4e44135269a51889f6.tar.xz |
Fix copy for file resources.
Diffstat (limited to '')
-rw-r--r-- | doc/ref/guile/webdav.texi | 34 | ||||
-rw-r--r-- | module/calp/server/webdav.scm | 28 | ||||
-rw-r--r-- | module/calp/webdav/resource/base.scm | 109 | ||||
-rw-r--r-- | module/calp/webdav/resource/file.scm | 22 | ||||
-rw-r--r-- | tests/test/webdav-server.scm | 8 |
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) '())) |