1 files changed, 29 insertions, 23 deletions

diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm
index 83725825..f2aab8d4 100644
--- a/module/calp/webdav/propfind.scm
+++ b/module/calp/webdav/propfind.scm
@@ -1,10 +1,14 @@
 (define-module (calp webdav propfind)
   :use-module (calp webdav property)
   :use-module (calp webdav resource)
+  :use-module ((calp webdav resource base) :select (resource?))
   :use-module (calp namespaces)
   :use-module (srfi srfi-1)
   :use-module (sxml namespaced)
   :use-module (sxml namespaced util)
+  :use-module ((hnh util) :select (->))
+  :use-module ((hnh util table) :select (table))
+  :use-module (hnh util type)
   :export (propfind-selected-properties
            propfind-all-live-properties
            propfind-most-live-properties
@@ -21,6 +25,8 @@
 ;; return a list of propstat elements
 ;; work for both dead and alive objects
 (define (propfind-selected-properties resource properties)
+  (typecheck resource resource?)
+  (typecheck properties (list-of xml-element?))
   (map (lambda (el) (get-property resource el))
        properties))
 
@@ -31,18 +37,21 @@
 
 ;; Returns a list of <propstat> objects.
 (define (propfind-all-live-properties resource)
-  (map (lambda (p) ((cdr p) resource))
+  (typecheck resource resource?)
+  (map (lambda (p) ((property-getter (cdr p)) resource))
        (live-properties resource)))
 
 ;; Returns a list of <propstat> objects.
 ;; The list being the live properties defined by [WEBDAV]
 (define (propfind-most-live-properties resource)
+  (typecheck resource resource?)
   (map (lambda (p) ((property-getter (cdr p)) resource))
        webdav-properties))
 
 ;; Returns a list of <propstat> objects.
 ;; All "dead" properties on resource.
 (define (propfind-all-dead-properties resource)
+  (typecheck resource resource?)
   (map (lambda (v) (propstat 200 (list v)))
        (dead-properties resource)))
 
@@ -50,24 +59,17 @@
 
 
 
-(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 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))))
+  (typecheck sxml xml-element?)
+  (typecheck resource resource?)
+
+  (let ((propname (find-child ((xml webdav 'propname)) (xml-element-children sxml)))
+        (allprop  (find-child ((xml webdav 'allprop))  (xml-element-children sxml)))
+        (include  (find-child ((xml webdav 'include))  (xml-element-children sxml)))
+        (prop     (find-child ((xml webdav 'prop))     (xml-element-children sxml))))
+
     (merge-propstats
      (cond ((and allprop include)
             ;; Return "all" properties + those noted by <include/>
@@ -75,25 +77,29 @@
                     (propfind-all-dead-properties resource)
                     (propfind-selected-properties
                      resource
-                     (map car (cdr include)))))
+                     (xml-element-children include))))
+
            (allprop
             ;; Return "all" properties
             (append (propfind-most-live-properties resource)
                     (propfind-all-dead-properties resource)))
+
            (propname
             ;; Return the list of available properties
+            ;; each entry is an xml element, with no content
             (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))))))
+                   (append
+                    (map (lambda (el) (-> el (children '()) (properties (table))))
+                     (dead-properties resource))
+                    (map car (live-properties resource))))))
+
            (prop
             ;; Return the properties listed
             (propfind-selected-properties
              resource
-             (map car (cdr prop))))
+             (xml-element-children prop)))
+
            (else
             (scm-error 'bad-request "parse-propfind"
                        "Invalid search query ~s" (list sxml) (list sxml)))))))