Update things depending on namespaced sxml.sxml-work

Update all code to emit correctly formed namespaced sxml objects,
instead of the old list based approach.

Also introduces a number of typechecks which in semi-related parts of
the code.

Note that the webdav-server test is currently broken.

5 files changed, 126 insertions, 112 deletions

diff --git a/tests/unit/sxml/sxml-namespaced.scm b/tests/unit/sxml/sxml-namespaced.scm
index 18e35225..ee1407d6 100644
--- a/tests/unit/sxml/sxml-namespaced.scm
+++ b/tests/unit/sxml/sxml-namespaced.scm
@@ -42,6 +42,18 @@
 ;;; TODO Attributes
 ;;; TODO children
 
+(test-group "Constructing XML documents"
+  (test-assert "With simple content"
+    ((xml 'a) "Hello"))
+
+  (test-assert "Full document"
+    ((xml 'html)
+     ((xml 'head)
+      ((xml #f 'meta '((charset "UTF-8"))))
+      ((xml 'title) "Title text"))
+     ((xml 'body)
+      "This document left blank"))))
+
 
 
 (test-group "xml->namespaced-sxml"
@@ -73,7 +85,7 @@
      root: ((xml 'tag)))
     (xml->namespaced-sxml "<?xml encoding=\"utf-8\" version=\"1.0\"?><tag/>"))
 
-  (test-equal "Document with whitespace in it"
+  (test-equal "Document with (untrimmed) whitespace in it"
     (xml-document
      pi: (list (pi-element 'xml ""))
      root: ((xml 'root)
@@ -82,6 +94,16 @@
     (xml->namespaced-sxml "<?xml?><root> <a/></root>"
                           trim-whitespace?: #f))
 
+  ;; An earlier version trimmed whitespace down inte empty strings,
+  ;; instead of (correctly) omitting the strings completely.
+  (test-equal "Document with (trimmed) whitespace in it"
+    (xml-document
+     pi: (list (pi-element 'xml ""))
+     root: ((xml 'root)
+            ((xml 'a))))
+    (xml->namespaced-sxml "<?xml?><root> <a/></root>"
+                          trim-whitespace?: #t))
+
   (test-equal "Whitespace before root is discarded kept"
     (xml-document
      pi: (list (pi-element 'xml ""))
diff --git a/tests/unit/webdav/webdav-file.scm b/tests/unit/webdav/webdav-file.scm
index 85f4738d..cc7c98dd 100644
--- a/tests/unit/webdav/webdav-file.scm
+++ b/tests/unit/webdav/webdav-file.scm
@@ -20,6 +20,7 @@
 (define test-root (mkdtemp (string-copy "/tmp/calp-test-XXXXXX")))
 
 (define root-resource (make <file-resource>
+                        name: "*root*"
                         root: test-root))
 
 
diff --git a/tests/unit/webdav/webdav-property.scm b/tests/unit/webdav/webdav-property.scm
index 0b465e82..b3edf7ac 100644
--- a/tests/unit/webdav/webdav-property.scm
+++ b/tests/unit/webdav/webdav-property.scm
@@ -25,34 +25,34 @@
 
 ;; (test-equal "/" (href->string (href resource)))
 (test-equal "Basic propstat"
-    (propstat 200 (list (list (xml webdav 'getcontentlength) 4)))
+    (propstat 200 (list ((xml webdav 'getcontentlength) "4")))
     (getcontentlength resource))
 
 
 ;;; NOTE propstat's return order isn't stable, making this test possibly fail
-(let ((ps (list (propstat 200 (list `(,(xml webdav 'displayname) "Displayname")))
-                (propstat 200 (list `(,(xml webdav 'getcontenttype) "text/plain"))))))
+(let ((ps (list (propstat 200 (list ((xml webdav 'displayname) "Displayname")))
+                (propstat 200 (list ((xml webdav 'getcontenttype) "text/plain"))))))
   (test-equal "Propstat merger"
     (list (propstat 200
-                    (list (list (xml webdav 'getcontenttype) "text/plain")
-                          (list (xml webdav 'displayname) "Displayname"))))
+                    (list ((xml webdav 'getcontenttype) "text/plain")
+                          ((xml webdav 'displayname) "Displayname"))))
     (merge-propstats ps)))
 
 (test-group "Propstat -> namespaced sxml"
   (test-equal "Simple"
-    `(,(xml webdav 'propstat)
-      (,(xml webdav 'prop) (,(xml webdav 'displayname) "test"))
-      (,(xml webdav 'status) "HTTP/1.1 200 OK"))
-    (propstat->namespaced-sxml (propstat 200 `((,(xml webdav 'displayname) "test")) )))
+    ((xml webdav 'propstat)
+     ((xml webdav 'prop) ((xml webdav 'displayname) "test"))
+     ((xml webdav 'status) "HTTP/1.1 200 OK"))
+    (propstat->namespaced-sxml (propstat 200 (list ((xml webdav 'displayname) "test")))))
 
   ;; TODO populated error field
 
   (test-equal "With response description"
-    `(,(xml webdav 'propstat)
-      (,(xml webdav 'prop) (,(xml webdav 'displayname) "test"))
-      (,(xml webdav 'status) "HTTP/1.1 403 Forbidden")
-      (,(xml webdav 'responsedescription) "Try logging in"))
-    (propstat->namespaced-sxml (propstat 403 `((,(xml webdav 'displayname) "test"))
+    ((xml webdav 'propstat)
+     ((xml webdav 'prop) ((xml webdav 'displayname) "test"))
+     ((xml webdav 'status) "HTTP/1.1 403 Forbidden")
+     ((xml webdav 'responsedescription) "Try logging in"))
+    (propstat->namespaced-sxml (propstat 403 (list ((xml webdav 'displayname) "test"))
                                          responsedescription: "Try logging in"))))
 
 '((calp webdav property))
diff --git a/tests/unit/webdav/webdav-propfind.scm b/tests/unit/webdav/webdav-propfind.scm
index 8144605a..220b84d3 100644
--- a/tests/unit/webdav/webdav-propfind.scm
+++ b/tests/unit/webdav/webdav-propfind.scm
@@ -17,6 +17,8 @@
 (define (sort-symbols symbs)
   (sort* symbs string<=? symbol->string))
 
+;;; Propstats are unsorted, we just sort them here for easier
+;;; equivalence checks in the tests.
 (define (sort-propstats propstats)
   (map
    (lambda (pr)
@@ -24,7 +26,7 @@
      (modify pr propstat-property*
              (lambda (it)
               (sort* it
-                     string< (compose symbol->string xml-element-tagname car)))))
+                     string< (compose symbol->string xml-element-tagname)))))
    (sort* propstats < propstat-status-code)))
 
 
@@ -49,24 +51,25 @@
                 (test-equal (format #f "Propstat well formed: ~a" (propstat-property propstat))
                   1 (length (propstat-property propstat)))
                 (test-assert "Propstat child is xml"
-                  (xml-element? (caar (propstat-property propstat)))))
+                  (xml-element? (car (propstat-property propstat)))))
               most)
 
     (test-equal "Correct keys"
       '(creationdate displayname getcontentlanguage getcontentlength
                      getcontenttype getetag getlastmodified
                      lockdiscovery resourcetype supportedlock)
-      (sort-symbols (map (compose xml-element-tagname caar propstat-property) most)))))
+      (sort-symbols (map (compose xml-element-tagname car propstat-property)
+                         most)))))
 
 
 (test-equal "propfind-selected-properties"
-  (list (propstat 404 `((,(xml webdav 'displayname)))))
-  (propfind-selected-properties resource (list (xml webdav 'displayname))))
+  (list (propstat 404 (list ((xml webdav 'displayname)))))
+  (propfind-selected-properties resource (list ((xml webdav 'displayname)))))
 
 (test-group "parse-propfind"
   (test-group "propname"
-    (let ((props (parse-propfind `(,(xml webdav 'propfind)
-                                   (,(xml webdav 'propname)))
+    (let ((props (parse-propfind ((xml webdav 'propfind)
+                                  ((xml webdav 'propname)))
                                 resource)))
 
 
@@ -76,11 +79,8 @@
 
      (test-assert "Propstat objects are returned" (propstat? (car props)))
      (for-each (lambda (el)
-                 (test-assert "Base is list" (list? el))
-                 (test-eqv "List only contains head el" 1 (length el))
-                 #;
-                 (test-assert (format #f "Head is an xml tag: ~a" el)
-                   (xml-element? (car el))))
+                 (test-assert "Each entry is an xml element" (xml-element*? el))
+                 (test-eqv "The enrties lack children" 0 (length (xml-element-children el))))
                (propstat-property (car props)))
 
      #;
@@ -88,128 +88,119 @@
        (sort-symbols (cons* 'test 'is-virtual webdav-keys))
        (sort-symbols (map (compose xml-element-tagname car)
                           (propstat-property (car props)))))
-
-     (test-group "No property should contain any data"
-       (for-each (lambda (el)
-                   (test-eqv (format #f "Propname property: ~s" el)
-                     1 (length el)))
-                 (propstat-property (car props))))))
+     ))
 
 
   (test-group "direct property list"
-    (let ((props (parse-propfind `((xml webdav 'propfind)
-                                   (,(xml webdav 'prop)
-                                    (,(xml webdav 'displayname))))
+    (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)
-                                        ))))
+        (list (propstat 404 (list ((xml webdav 'displayname)))))
         props)))
 
   ;; TODO test that calendar properties are reported by propname
   ;; TODO test that non-native caldav propreties aren't reported by allprop
 
   (test-group "allprop"
-    (let ((props (parse-propfind `(,(xml webdav 'propfind)
-                                   (,(xml webdav 'allprop)))
+    (let ((props (parse-propfind ((xml webdav 'propfind)
+                                  ((xml webdav 'allprop)))
                                  resource)))
 
 
       (test-equal "Propfind result"
         (list
          (propstat 200
-                   (list (list (xml webdav 'creationdate)
-                               (datetime->string dt "~Y-~m-~dT~H:~M:~SZ"))
-                         (list (xml webdav 'getcontentlength)
-                               4)
-                         (list (xml webdav 'getcontenttype)
-                               "application/binary")
-                         (list (xml webdav 'getlastmodified)
-                               "Thu, 01 Jan 1970 00:00:00 GMT")
-                         (list (xml webdav 'lockdiscovery) '())
-                         (list (xml webdav 'resourcetype)
+                   (list ((xml webdav 'creationdate)
+                          (datetime->string dt "~Y-~m-~dT~H:~M:~SZ"))
+                         ((xml webdav 'getcontentlength)
+                          "4")
+                         ((xml webdav 'getcontenttype)
+                          "application/binary")
+                         ((xml webdav 'getlastmodified)
+                          "Thu, 01 Jan 1970 00:00:00 GMT")
+                         ((xml webdav 'lockdiscovery))
+                         ((xml webdav 'resourcetype)
                                         ; (list (xml webdav 'collection))
-                               )
-                         (list (xml webdav 'supportedlock) '())
+                          )
+                         ((xml webdav 'supportedlock))
                          ;; (list (xml ns1 'test) "Content")
                          ))
-         (propstat 404 (list (list (xml webdav 'displayname))
-                             (list (xml webdav 'getcontentlanguage))))
+         (propstat 404 (list ((xml webdav 'displayname))
+                             ((xml webdav 'getcontentlanguage))))
          (propstat 501
-                   (list (list (xml webdav 'getetag))
-                        )))
+                   (list ((xml webdav 'getetag)))))
         (sort-propstats props))))
 
 
   (test-group "allprop with include"
-    (let ((props (parse-propfind `((xml webdav 'propfind)
-                                   (,(xml webdav 'allprop))
-                                   (,(xml webdav 'include)))
+    (let ((props (parse-propfind ((xml webdav 'propfind)
+                                  ((xml webdav 'allprop))
+                                  ((xml webdav 'include)))
                                  resource)))
 
 
       (test-equal "Include NOTHING"
         (list
          (propstat 200
-                   (list (list (xml webdav 'creationdate)
-                               (datetime->string dt "~Y-~m-~dT~H:~M:~SZ"))
-                         (list (xml webdav 'getcontentlength)
-                               4)
-                         (list (xml webdav 'getcontenttype)
-                               "application/binary")
-                         (list (xml webdav 'getlastmodified)
-                               "Thu, 01 Jan 1970 00:00:00 GMT")
-                         (list (xml webdav 'lockdiscovery) '())
-                         (list (xml webdav 'resourcetype)
+                   (list ((xml webdav 'creationdate)
+                          (datetime->string dt "~Y-~m-~dT~H:~M:~SZ"))
+                         ((xml webdav 'getcontentlength)
+                          "4")
+                         ((xml webdav 'getcontenttype)
+                          "application/binary")
+                         ((xml webdav 'getlastmodified)
+                          "Thu, 01 Jan 1970 00:00:00 GMT")
+                         ((xml webdav 'lockdiscovery))
+                         ((xml webdav 'resourcetype)
                                         ; (list (xml webdav 'collection))
-                               )
-                         (list (xml webdav 'supportedlock) '())
+                          )
+                         ((xml webdav 'supportedlock))
                          ;; (list (xml ns1 'test) "Content")
                          ))
-         (propstat 404 (list (list (xml webdav 'displayname))
-                             (list (xml webdav 'getcontentlanguage))))
+         (propstat 404 (list ((xml webdav 'displayname))
+                             ((xml webdav 'getcontentlanguage))))
          (propstat 501
-                   (list (list (xml webdav 'getetag))
+                   (list ((xml webdav 'getetag))
                          )))
         (sort-propstats props)))
 
 
-    (let ((props (parse-propfind `(,(xml webdav 'propfind)
-                                   (,(xml webdav 'allprop))
-                                   (,(xml webdav 'include)
-                                    (,(xml virtual-ns 'isvirtual))))
+    (let ((props (parse-propfind ((xml webdav 'propfind)
+                                  ((xml webdav 'allprop))
+                                  ((xml webdav 'include)
+                                   ((xml virtual-ns 'isvirtual))))
                                  resource)))
 
       (test-equal "Include isvirtual"
         (list
          (propstat 200
-                   (list (list (xml webdav 'creationdate) (datetime->string dt "~Y-~m-~dT~H:~M:~SZ"))
-                         (list (xml webdav 'getcontentlength) 4)
-                         (list (xml webdav 'getcontenttype) "application/binary")
-                         (list (xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT")
-                         (list (xml virtual-ns 'isvirtual) "true")
-                         (list (xml webdav 'lockdiscovery) '())
-                         (list (xml webdav 'resourcetype))
-                         (list (xml webdav 'supportedlock) '())
+                   (list ((xml webdav 'creationdate) (datetime->string dt "~Y-~m-~dT~H:~M:~SZ"))
+                         ((xml webdav 'getcontentlength) "4")
+                         ((xml webdav 'getcontenttype) "application/binary")
+                         ((xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT")
+                         ((xml virtual-ns 'isvirtual) "true")
+                         ((xml webdav 'lockdiscovery))
+                         ((xml webdav 'resourcetype))
+                         ((xml webdav 'supportedlock))
                          ;; (list (xml ns1 'test) "Content")
                          ))
-         (propstat 404 (list (list (xml webdav 'displayname))
-                             (list (xml webdav 'getcontentlanguage))))
-         (propstat 501
-                   (list (list (xml webdav 'getetag))
-                     )))
+         (propstat 404 (list ((xml webdav 'displayname))
+                             ((xml webdav 'getcontentlanguage))))
+         (propstat 501 (list ((xml webdav 'getetag)))))
         (sort-propstats props)))))
 
 
 (test-equal
     (list (propstat 200
-                    `((,(xml webdav 'getcontentlength) 4)
-                      (,(xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT")
-                      (,(xml webdav 'resourcetype))))
+                    (list ((xml webdav 'getcontentlength) "4")
+                          ((xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT")
+                          ((xml webdav 'resourcetype))))
           (propstat 404
-                    `((,(xml webdav 'checked-in))
-                      (,(xml webdav 'checked-out))
-                      (,(xml (string->symbol "http://apache.org/dav/props/") 'executable)))))
+                    (list ((xml webdav 'checked-in))
+                          ((xml webdav 'checked-out))
+                          ((xml (string->symbol "http://apache.org/dav/props/") 'executable)))))
   (let ((request (xml->namespaced-sxml
                   "<?xml version=\"1.0\" encoding=\"utf-8\"?>
 <propfind xmlns=\"DAV:\">
@@ -223,7 +214,7 @@
   </prop>
 </propfind>")))
 
-    (sort-propstats (parse-propfind (caddr request) resource))))
+    (sort-propstats (parse-propfind (xml-document-root request) resource))))
 
 (test-equal "All dead properties"
   (list #;
diff --git a/tests/unit/webdav/webdav-resource.scm b/tests/unit/webdav/webdav-resource.scm
index f6ebf3bb..f81487ed 100644
--- a/tests/unit/webdav/webdav-resource.scm
+++ b/tests/unit/webdav/webdav-resource.scm
@@ -52,7 +52,7 @@
  (let ((props (live-properties resource)))
    (test-assert (list? props))
    (for-each (lambda (pair)
-               ;; (test-assert (xml-element? (car pair)))
+               (test-assert (xml-element? (car pair)))
                (test-assert (live-property? (cdr pair)))
                (test-assert (procedure? (property-getter (cdr pair))))
                (test-assert (procedure? (property-setter-generator (cdr pair)))))
@@ -61,36 +61,36 @@
 
 (define ns1 (string->symbol "http://example.com/namespace"))
 
-(set-dead-property! resource `(,(xml ns1 'test) "Content"))
+(set-dead-property! resource ((xml ns1 'test) "Content"))
 
 (test-equal "Get dead property"
-  (propstat 200 (list (list (xml ns1 'test) "Content")))
-  (get-dead-property resource (xml ns1 'test)))
+  (propstat 200 (list ((xml ns1 'test) "Content")))
+  (get-dead-property resource ((xml ns1 'test))))
 
 (test-equal "Get live property"
-  (propstat 404 (list (list (xml ns1 'test))))
-  (get-live-property resource (xml ns1 'test)))
+  (propstat 404 (list ((xml ns1 'test))))
+  (get-live-property resource ((xml ns1 'test))))
 
 (test-group "Dead properties"
   (test-equal "Existing property"
-    (propstat 200 (list (list (xml ns1 'test) "Content")))
-    (get-property resource (xml ns1 'test)))
+    (propstat 200 (list ((xml ns1 'test) "Content")))
+    (get-property resource ((xml ns1 'test))))
 
   (test-equal "Missing property"
-    (propstat 404 (list (list (xml ns1 'test2))))
-    (get-property resource (xml ns1 'test2))))
+    (propstat 404 (list ((xml ns1 'test2))))
+    (get-property resource ((xml ns1 'test2)))))
 
 (test-group "Live Properties"
 
   ;; TODO these tests were written when displayname always returned 200, but have since changed to test for 404.
   ;; Change to another property which return 200
   (test-equal "Existing live property (through get-live-property)"
-    (propstat 404 `((,(xml webdav 'displayname))))
-    (get-live-property resource (xml webdav 'displayname)))
+    (propstat 404 (list ((xml webdav 'displayname))))
+    (get-live-property resource ((xml webdav 'displayname))))
 
   (test-equal "Existing live property (thrtough get-property)"
-    (propstat 404 `((,(xml webdav 'displayname))))
-    (get-property resource (xml webdav 'displayname))))
+    (propstat 404 (list ((xml webdav 'displayname))))
+    (get-property resource ((xml webdav 'displayname)))))
 
 (test-group "lookup-resource"
   (let* ((root (make <virtual-resource> name: "*root*"))