diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-14 22:32:09 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-14 22:32:09 +0200 |
commit | 4b7f4a1449b87aeec751a652d756ac9d85c1ff8f (patch) | |
tree | 9042e87e345511d77689dbe4008be6625057aad1 /module | |
parent | Fix webdav move. (diff) | |
download | calp-4b7f4a1449b87aeec751a652d756ac9d85c1ff8f.tar.gz calp-4b7f4a1449b87aeec751a652d756ac9d85c1ff8f.tar.xz |
Fix propfind.
* Allows propfind elements to appear in any order
* properly ignored unknown elements
* works directly with namespaced sxml
Diffstat (limited to 'module')
-rw-r--r-- | module/calp/server/webdav.scm | 34 | ||||
-rw-r--r-- | module/calp/webdav/propfind.scm | 87 |
2 files changed, 69 insertions, 52 deletions
diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm index ed9fd9b8..02c0acfa 100644 --- a/module/calp/server/webdav.scm +++ b/module/calp/server/webdav.scm @@ -135,6 +135,21 @@ [(*TOP* ,root) root] [,root root])) +(define (root-element/namespaced sxml) + (cond ((not (list? sxml)) (scm-error 'misc-error "root-element/namespaced" + "Argument is invalid sxml: ~s" + (list sxml) #f)) + ((null? (car sxml)) (scm-error 'misc-error "root-element/namespaced" + "No root in an empty list" + '() #f)) + ((eq? '*TOP* (car sxml)) + (let ((children (cdr sxml))) + (cond ((null? children) #f) + ((pi-element? (car children)) + (cadr children)) + (else (car children))))) + (else sxml))) + (define root-resource (make-parameter #f)) @@ -227,18 +242,16 @@ ((infinity) (all-resources-under resource href)))) ;; Body, if it exists, MUST have be a DAV::propfind object - (define-values (property-request namespaces*) + (define property-request (cond ((string? body) - (-> body - xml->namespaced-sxml - (namespaced-sxml->sxml/namespaces (map swap namespaces)))) + (xml->namespaced-sxml body)) ((bytevector? body) (-> body - (bytevector->string (make-transcoder (utf-8-codec))) - xml->namespaced-sxml - (namespaced-sxml->sxml/namespaces (map swap namespaces)))) - (else (values '(d:propfind (d:allprop)) - `((d . ,webdav)))))) + (bytevector->string + (make-transcoder (utf-8-codec))) + xml->namespaced-sxml)) + (else `(,(xml webdav 'propfind) + (,(xml webdav 'allprop)))))) (catch 'bad-request @@ -254,8 +267,7 @@ `(,(xml webdav 'response) (,(xml webdav 'href) ,(href->string href)) ,@(map propstat->namespaced-sxml - (parse-propfind (root-element property-request) - (map swap namespaces*) + (parse-propfind (root-element/namespaced property-request) resource))))) namespaces: output-namespaces port: port) diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm index e6becafd..3e86304c 100644 --- a/module/calp/webdav/propfind.scm +++ b/module/calp/webdav/propfind.scm @@ -1,7 +1,8 @@ (define-module (calp webdav propfind) :use-module (calp webdav property) :use-module (calp webdav resource) - :use-module (sxml match) + :use-module (calp namespaces) + :use-module (srfi srfi-1) :use-module (sxml namespaced) :export (propfind-selected-properties propfind-all-live-properties @@ -48,46 +49,50 @@ +(define (find-element target list) + (define target* (xml-element-hash-key target)) + (find (lambda (x) (and (list? x) + (not (null? x)) + (xml-element? (car x)) + (equal? target* (xml-element-hash-key (car x))))) + list)) ;; Takes a propfind xml element (tree), and a webdav resource object. ;; Returns a list of <propstat> objects. -(define (parse-propfind sxml namespaces resource) - (merge-propstats - ;; TODO Allow *TOP* and *PI*? - (sxml-match sxml - ((d:propfind (d:propname)) - ;; Return the list of available properties - (list (propstat - 200 - ;; car to get tagname, list to construct a valid xml element - (map (compose list car) - (append - (dead-properties resource) - (live-properties resource)))))) - - ((d:propfind (d:allprop)) - ;; Return "all" properties - (append - (propfind-most-live-properties resource) - (propfind-all-dead-properties resource))) - - ((d:propfind (d:allprop) (d:include ,properties ...)) - ;; Return "all" properties + those noted by <include/> - (append - (propfind-most-live-properties resource) - (propfind-all-dead-properties resource) - (propfind-selected-properties - resource - (map (lambda (prop) (car (sxml->namespaced-sxml prop namespaces))) - properties)))) - - ((d:propfind (d:prop ,properties ...)) - ;; Return the properties listed - (propfind-selected-properties - resource - (map (lambda (prop) (car (sxml->namespaced-sxml prop namespaces))) - properties))) - - (,default (scm-error 'bad-request "parse-propfind" - "Invalid search query ~s" (list default) (list default))) - ))) +(define (parse-propfind sxml resource) + ;; (assert (list? sxml)) + ;; (assert (not (null? sxml))) + ;; (assert eq? 'd:propfid (car sxml)) + (let ((propname (find-element (xml webdav 'propname) (cdr sxml))) + (allprop (find-element (xml webdav 'allprop) (cdr sxml))) + (include (find-element (xml webdav 'include) (cdr sxml))) + (prop (find-element (xml webdav 'prop) (cdr sxml)))) + (merge-propstats + (cond ((and allprop include) + ;; Return "all" properties + those noted by <include/> + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource) + (propfind-selected-properties + resource + (map car (cdr include))))) + (allprop + ;; Return "all" properties + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + ;; Return the list of available properties + (list (propstat + 200 + ;; car to get tagname, list to construct a valid xml element + (map (compose list car) + (append + (dead-properties resource) + (live-properties resource)))))) + (prop + ;; Return the properties listed + (propfind-selected-properties + resource + (map car (cdr prop)))) + (else + (scm-error 'bad-request "parse-propfind" + "Invalid search query ~s" (list sxml) (list sxml))))))) |