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 | |
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 '')
-rw-r--r-- | module/calp/server/webdav.scm | 34 | ||||
-rw-r--r-- | module/calp/webdav/propfind.scm | 87 | ||||
-rw-r--r-- | tests/test/webdav.scm | 37 |
3 files changed, 87 insertions, 71 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))))))) diff --git a/tests/test/webdav.scm b/tests/test/webdav.scm index 10dcf95b..0962a89e 100644 --- a/tests/test/webdav.scm +++ b/tests/test/webdav.scm @@ -137,8 +137,8 @@ (test-group "parse-propfind" (test-group "propname" - (let ((props (parse-propfind `(d:propfind (d:propname)) - `((d . ,webdav)) + (let ((props (parse-propfind `(,(xml webdav 'propfind) + (,(xml webdav 'propname))) resource))) @@ -169,8 +169,9 @@ (test-group "direct property list" - (let ((props (parse-propfind `(d:propfind (d:prop (d:displayname))) - `((d . ,webdav)) + (let ((props (parse-propfind `((xml webdav 'propfind) + (,(xml webdav 'prop) + (,(xml webdav 'displayname)))) resource))) (test-equal "Simple lookup" (list (propstat 404 (list (list (xml webdav 'displayname) @@ -181,8 +182,8 @@ ;; TODO test that non-native caldav propreties aren't reported by allprop (test-group "allprop" - (let ((props (parse-propfind '(d:propfind (d:allprop)) - `((d . ,webdav)) + (let ((props (parse-propfind `(,(xml webdav 'propfind) + (,(xml webdav 'allprop))) resource))) @@ -213,8 +214,9 @@ (test-group "allprop with include" - (let ((props (parse-propfind '(d:propfind (d:allprop) (d:include)) - `((d . ,webdav)) + (let ((props (parse-propfind `((xml webdav 'propfind) + (,(xml webdav 'allprop)) + (,(xml webdav 'include))) resource))) @@ -244,10 +246,10 @@ (sort-propstats props))) - (let ((props (parse-propfind `(d:propfind (d:allprop) - (d:include (x:isvirtual))) - `((d . ,webdav) - (x . ,virtual-ns)) + (let ((props (parse-propfind `(,(xml webdav 'propfind) + (,(xml webdav 'allprop)) + (,(xml webdav 'include) + (,(xml virtual-ns 'isvirtual)))) resource))) (test-equal "Include isvirtual" @@ -311,10 +313,8 @@ `((,(xml webdav 'checked-in)) (,(xml webdav 'checked-out)) (,(xml (string->symbol "http://apache.org/dav/props/") 'executable))))) - (let ((request namespaces - (namespaced-sxml->sxml/namespaces - (xml->namespaced-sxml - "<?xml version=\"1.0\" encoding=\"utf-8\"?> + (let ((request (xml->namespaced-sxml + "<?xml version=\"1.0\" encoding=\"utf-8\"?> <propfind xmlns=\"DAV:\"> <prop> <getcontentlength/> @@ -324,10 +324,9 @@ <checked-in/> <checked-out/> </prop> -</propfind>") - `((,(string->symbol "DAV:") . d))))) +</propfind>"))) - (sort-propstats (parse-propfind (caddr request) (map swap namespaces) resource)))) + (sort-propstats (parse-propfind (caddr request) resource)))) |