diff options
Diffstat (limited to 'module/calp')
| -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 |
3 files changed, 99 insertions, 60 deletions
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) |