Fix propfind.

* Allows propfind elements to appear in any order
* properly ignored unknown elements
* works directly with namespaced sxml

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))))