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.

20 files changed, 491 insertions, 400 deletions

diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm
index 3413f254..703e4783 100644
--- a/module/calp/server/webdav.scm
+++ b/module/calp/server/webdav.scm
@@ -219,15 +219,17 @@
 
               ;; Body, if it exists, MUST have be a DAV::propfind object
               (define property-request
-                (cond ((string? body)
-                       (xml->namespaced-sxml body))
-                      ((bytevector? body)
-                       (-> body
-                           (bytevector->string
-                            (make-transcoder (utf-8-codec)))
-                           xml->namespaced-sxml))
-                      (else `(,(xml webdav 'propfind)
-                              (,(xml webdav 'allprop))))))
+                (xml-document-root
+                 (cond ((string? body)
+                        (xml->namespaced-sxml body))
+                       ((bytevector? body)
+                        (-> body
+                            (bytevector->string
+                             (make-transcoder (utf-8-codec)))
+                            xml->namespaced-sxml))
+                       (else (xml-document
+                              root: ((xml webdav 'propfind)
+                                     ((xml webdav 'allprop))))))))
 
 
               (catch 'bad-request
@@ -238,11 +240,12 @@
                            headers: '((content-type . (application/xml))))
                           (lambda (port)
                             (namespaced-sxml->xml
-                             `(,(xml webdav 'multistatus)
-                               ,@(for (href . resource) in requested-resources
-                                      `(,(xml webdav 'response)
-                                        (,(xml webdav 'href) ,(href->string href))
-                                        ,@(map propstat->namespaced-sxml
+                             (apply
+                              (xml webdav 'multistatus)
+                              (for (href . resource) in requested-resources
+                                   (apply (xml webdav 'response)
+                                          ((xml webdav 'href) (href->string href))
+                                          (map propstat->namespaced-sxml
                                                (parse-propfind (root-element/namespaced property-request)
                                                                resource)))))
                              namespaces: output-namespaces
@@ -284,14 +287,15 @@
                                     (else (throw 'body-required))))
 
                             (namespaced-sxml->xml
-                             `(,(xml webdav 'multistatus)
-                               (,(xml webdav 'response)
-                                (,(xml webdav 'href) ,(href->string href))
-                                ,@(map propstat->namespaced-sxml
-                                       (parse-propertyupdate
-                                        (root-element request)
-                                        (map swap namespaces*)
-                                        resource))))
+                             ((xml webdav 'multistatus)
+                              (apply
+                               (xml webdav 'response)
+                               ((xml webdav 'href) (href->string href))
+                               (map propstat->namespaced-sxml
+                                    (parse-propertyupdate
+                                     (root-element request)
+                                     (map swap namespaces*)
+                                     resource))))
                              port: port))))
                 (lambda (err proc fmt args data)
                   (values (build-response
diff --git a/module/calp/webdav/property.scm b/module/calp/webdav/property.scm
index 4e235f81..3c919e2e 100644
--- a/module/calp/webdav/property.scm
+++ b/module/calp/webdav/property.scm
@@ -42,7 +42,7 @@
   ;; @example
   ;; `((,(xml ns tag) "Content"))
   ;; @end example
-  propstat-property
+  (propstat-property type: (list-of xml-element?))
 
   ;; See [WEBCAL] propstat XML element
   (propstat-error keyword: error)
@@ -87,10 +87,15 @@
 ;;                         `((d:responsedescription ,it)))))
 
 (define (propstat->namespaced-sxml propstat)
-  `(,(xml webdav 'propstat)
-    (,(xml webdav 'prop) ,@(propstat-property propstat))
-    (,(xml webdav 'status) ,(http-status-line (propstat-status-code propstat)))
-    ,@(awhen (propstat-error propstat)
-             `((,(xml webdav 'error) ,it)))
-    ,@(awhen (propstat-response-description propstat)
-             `((,(xml webdav 'responsedescription) ,it)))))
+  (apply (xml webdav 'propstat)
+         (append
+
+          (list
+           (apply (xml webdav 'prop) (propstat-property propstat))
+           ((xml webdav 'status) (http-status-line (propstat-status-code propstat))))
+
+          (awhen (propstat-error propstat)
+                 (list ((xml webdav 'error) it)))
+
+          (awhen (propstat-response-description propstat)
+                 (list ((xml webdav 'responsedescription) it))))))
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)))))))
diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm
index 500aef90..d817342e 100644
--- a/module/calp/webdav/resource/base.scm
+++ b/module/calp/webdav/resource/base.scm
@@ -9,6 +9,8 @@
   :use-module (calp webdav property)
   :use-module (calp namespaces)
   :use-module ((hnh util) :select (unless))
+  :use-module (hnh util type)
+  :use-module (hnh util object)
   :use-module (rnrs bytevectors)
   :use-module (hnh util)
   :use-module (hnh util env)
@@ -99,16 +101,16 @@
            ))
 
 
-(define-record-type <live-property>
-  (make-live-property% getter setter-generator remover-generator)
-  live-property?
-  (getter property-getter)
-  (setter-generator property-setter-generator)
-  (remover-generator property-remover-generator))
+(define-type (live-property)
+  (property-getter            keyword: getter  type: procedure?)
+  (property-setter-generator  keyword: setter  type: procedure?)
+  (property-remover-generator keyword: remover type: (or false? procedure?)))
 
-(define* (make-live-property getter setter-generator optional: remover-generator)
-  (make-live-property% getter setter-generator remover-generator))
 
+(define* (make-live-property getter setter-generator optional: remover-generator)
+  (live-property getter: getter
+                 setter: setter-generator
+                 remover: remover-generator))
 
 
 ;; Collections are also resources, this is non-collection resources
@@ -124,8 +126,9 @@
 
   (dead-properties
    ;; Map from (namespace . tagname) pairs to namespaced xml element
-   init-form: (make-hash-table)
-   getter: dead-properties%)
+   ;; init-form: (make-hash-table)
+   init-form: '()
+   accessor: dead-properties%)
 
   ;; Attributes on data
   (displayname accessor: displayname* init-value: #f)
@@ -139,20 +142,38 @@
   (resource-cache init-value: (make-hash-table 0)
                   getter: resource-cache))
 
+
+(define-method (initialize (self <resource>) args)
+  (next-method)
+  ;; TODO (name self) when name is unbound gives a really weird error
+  (typecheck (name self)            string?             "<resource>.name")
+  (typecheck (displayname* self)    (or false? string?) "<resource>.displayname")
+  (typecheck (contentlanguage self) (or false? string?) "<resource>.contentlanguage")
+  ;; (typecheck (dead-properties self) (list-of xml-element?) "<resource>.dead-properties")
+  ;; (typecheck (resource-children self) ...)
+  )
+
 (define (resource? x)
   (is-a? x <resource>))
 
 
 (define (href->string href)
+  (typecheck href (list-of string?))
+
   (if (null? href)
       "/" (string-join href "/" 'prefix)))
 
 (define (string->href s)
+  (typecheck s string?)
+
   (remove string-null?
           (string-split s #\/)))
 
 ;; parent must be the head of child, elements in child after that is "free range"
 (define (href-relative parent child)
+  (typecheck parent (list-of string?))
+  (typecheck child (list-of string?))
+
   (cond ((null? parent) child)
         ((null? child) (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f))
         ((equal? (car parent) (car child))
@@ -169,7 +190,7 @@
          '() #f))
 
 (define-method (set-content! (self <resource>) content)
-  (throw 'msic-error "set-content!<resource>"
+  (throw 'misc-error "set-content!<resource>"
          "Base <resource> doesn't implement (setting) content, please override this method"
          '() #f))
 
@@ -292,7 +313,10 @@
 ;;; All get-*-property methods return propstat elements
 
 (define (lookup-live-property resource xml-el)
-  (assoc-ref (live-properties resource) (xml-element-hash-key xml-el)))
+  (typecheck resource resource?)
+  (typecheck xml-el xml-element?)
+
+  (assoc-ref (live-properties resource) xml-el))
 
 ;;; TODO should {get,set}{,-{dead,live}}-property really be methods?
 ;;; - Live properties are defined by lookup-live-property, which isn't a
@@ -302,42 +326,43 @@
 ;;; - The combined should always just dispatch to either one
 
 (define-method (get-live-property (resource <resource>) xml-el)
+  (typecheck xml-el xml-element?)
+
   (cond ((lookup-live-property resource xml-el)
-         => (lambda (pair) ((property-getter pair) resource)))
-        (else (propstat 404 (list (list xml-el))))))
+         => (lambda (prop) ((property-getter prop) resource)))
+        (else (propstat 404 (list xml-el)))))
 
 (define-method (get-dead-property (resource <resource>) xml-el)
-  (cond ((hash-ref (dead-properties% resource)
-                   (xml-element-hash-key xml-el))
+  (typecheck xml-el xml-element?)
+
+  (cond ((find-child xml-el (dead-properties% resource))
          => (lambda (it) (propstat 200 (list it))))
-        (else (propstat 404 (list (list xml-el))))))
+        (else (propstat 404 (list xml-el)))))
 
-;;; Return a list xml tags (including containing list)
+;;; Return a list of xml elements, where each entry is a property
 (define-method (dead-properties (resource <resource>))
-  (hash-map->list (lambda (_ v) v)
-                  (dead-properties% resource)))
+  (dead-properties% resource))
 
-;; Value should be a list with an <xml-element> in it's car
 (define-method (set-dead-property (resource <resource>) value)
-  (unless (and (list? value)
-               (xml-element? (car value)))
-    (scm-error 'misc-error "set-dead-property"
-               "Invalid value, expected namespaced sxml"
-               '() #f))
+  (typecheck value xml-element?)
   (lambda ()
-    (hash-set! (dead-properties% resource)
-               (xml-element-hash-key (car value))
-               value)))
+    (set! (dead-properties% resource)
+      ;; TODO replace this with lens
+      (let loop ((rem (dead-properties% resource)))
+        (cond ((null? rem)
+               ;; Append
+               (list value))
+              ((equal? (xml-element-hash-key value)
+                       (xml-element-hash-key (car rem)))
+               ;; Replace
+               (cons value (cdr rem)))
+              (else (loop (cdr rem))))))))
 
 (define-method (set-live-property (resource <resource>) value)
-  (unless (and (list? value)
-               (xml-element? (car value)))
-    (scm-error 'misc-error "set-live-property"
-               "Invalid value, expected namespaced sxml"
-               '() #f))
+  (typecheck value xml-element?)
   (cond ((lookup-live-property resource (car value))
          => (lambda (prop) (apply (property-setter-generator prop)
-                             resource (cdr value))))
+                             resource (xml-element-children value))))
         (else #f)))
 
 (define (set-dead-property! resource value)
@@ -358,19 +383,16 @@
 ;;; But allows remove-* to have the same signature as set-*
 
 (define-method (remove-dead-property (resource <resource>) xml-tag)
-  (unless (xml-element? xml-tag)
-    (scm-error 'misc-error "remove-dead-property"
-               "Bad property element"
-               '() #f))
+  (typecheck xml-tag xml-element?)
   (lambda ()
-    (hash-remove! (dead-properties% resource)
-                  (xml-element-hash-key xml-tag))))
+    (set! (dead-properties% resource)
+      (remove (lambda (el)
+                (equal? (xml-element-hash-key el)
+                        (xml-element-hash-key xml-tag)))
+              (dead-properties% resource)))))
 
 (define-method (remove-live-property (resource <resource>) xml-tag)
-  (unless (xml-element? xml-tag)
-    (scm-error 'misc-error "remove-live-property"
-               "Bad property element"
-               '() #f))
+  (typecheck xml-tag xml-element?)
 
   (cond ((lookup-live-property resource xml-tag)
          => (lambda (prop)
@@ -396,11 +418,13 @@
 
 ;; xml-tag should be just the tag element, without a surounding list
 (define-method (get-property (resource <resource>) xml-tag)
+  (typecheck xml-tag xml-element?)
+
   (cond ((get-dead-property resource xml-tag)
          propstat-200? => identity)
         (else (get-live-property resource xml-tag))))
 
-;; Return an alist from xml-element tags (but not full elements with surrounding list)
+;; Return an alist from xml-element objects without children,
 ;; to generic procedures returning that value.
 ;; SHOULD be extended by children, which append their result to this result
 ;; @example
@@ -409,7 +433,8 @@
 ;;           specific-resource-properties))
 ;; @end example
 (define-method (live-properties (self <resource>))
-  (map (lambda (pair) (cons (xml-element-hash-key (xml webdav (car pair))) (cdr pair)))
+  (map (lambda (pair) (cons ((xml webdav (car pair)))
+                       (cdr pair)))
        webdav-properties))
 
 (define-method (setup-new-resource! (this <resource>) (parent <resource>))
@@ -463,7 +488,7 @@
 
 
 (define-method (creationdate (self <resource>))
-  (propstat 501 `((,(xml webdav 'creationdate)))))
+  (propstat 501 (list ((xml webdav 'creationdate)))))
 
 (define-method (set-creationdate! (self <resource>) _)
   (throw 'protected-resource "creationdate"))
@@ -471,74 +496,74 @@
 (define-method (displayname (self <resource>))
   (cond ((displayname* self)
          => (lambda (name)
-              (propstat 200 `((,(xml webdav 'displayname)
-                               ,name)))))
+              (propstat 200 (list ((xml webdav 'displayname)
+                                   name)))))
         (else
-         (propstat 404 `((,(xml webdav 'displayname)))))))
+         (propstat 404 (list ((xml webdav 'displayname)))))))
 
 (define-method (set-displayname! (self <resource>) value)
   (lambda () (set! (displayname* self) value)))
 
 (define-method (getcontentlanguage (self <resource>))
   (cond ((contentlanguage self)
-         => (lambda (lang) (propstat 200 `((,(xml webdav 'getcontentlanguage) ,lang)))))
-        (else (propstat 404 `((,(xml webdav 'getcontentlanguage)))))))
+         => (lambda (lang) (propstat 200 (list ((xml webdav 'getcontentlanguage) lang)))))
+        (else (propstat 404 (list ((xml webdav 'getcontentlanguage)))))))
 
 (define-method (set-getcontentlanguage! (self <resource>) value)
   (lambda () (set! (contentlanguage self) value)))
 
 (define-method (getcontentlength (self <resource>))
-  (propstat 501 `((,(xml webdav 'getcontentlength)))))
+  (propstat 501 (list ((xml webdav 'getcontentlength)))))
 
 (define-method (getcontentlength (self <resource>))
   (propstat 200
             (list
-             (list (xml webdav 'getcontentlength)
-                   (content-length self)))))
+             ((xml webdav 'getcontentlength)
+              (number->string
+               (content-length self))))))
 
 (define-method (set-getcontentlength! (self <resource>) _)
   (throw 'protected-resource "getcontentlength"))
 
 (define-method (getcontenttype (self <resource>))
-  (propstat 501 `((,(xml webdav 'getcontenttype)))))
+  (propstat 501 (list ((xml webdav 'getcontenttype)))))
 
 (define-method (set-getcontenttype! (self <resource>) _)
   (throw 'protected-resource "getcontenttype"))
 
 (define-method (getetag (self <resource>))
   ;; TODO
-  (propstat 501 `((,(xml webdav 'getetag)))))
+  (propstat 501 (list ((xml webdav 'getetag)))))
 
 (define-method (set-getetag! (self <resource>) _)
   (throw 'protected-resource "getetag"))
 
 (define-method (getlastmodified (self <resource>))
-  (propstat 200 `((,(xml webdav 'getlastmodified)
-                   ,(with-locale1
-                     LC_TIME "C"
-                     (lambda ()
-                      (datetime->string (unix-time->datetime 0) "~a, ~d ~b ~Y ~H:~M:~S GMT")))))))
+  (propstat 200 (list ((xml webdav 'getlastmodified)
+                       (with-locale1
+                        LC_TIME "C"
+                        (lambda ()
+                          (datetime->string (unix-time->datetime 0) "~a, ~d ~b ~Y ~H:~M:~S GMT")))))))
 
 (define-method (set-getlastmodified! (self <resource>) _)
   (throw 'protected-resource "getlastmodified"))
 
 (define-method (lockdiscovery (self <resource>))
-  (propstat 200 `((,(xml webdav 'lockdiscovery)
-                   ()))))
+  (propstat 200 (list ((xml webdav 'lockdiscovery)))))
 
 (define-method (set-lockdiscovery! (self <resource>) _)
   (throw 'protected-resource "lockdiscovery"))
 
 (define-method (resourcetype (self <resource>))
-  (propstat 200 `((,(xml webdav 'resourcetype)
-                   ,@(when (is-collection? self)
-                       `((,(xml webdav 'collection))))))))
+  (propstat 200 (list (apply (xml webdav 'resourcetype)
+                             (when (is-collection? self)
+                               (list ((xml webdav 'collection))))))))
 
 (define-method (set-resourcetype! (self <resource>) _)
   (throw 'protected-resource "resourcetype"))
 
 (define-method (supportedlock (self <resource>))
-  (propstat 200 `((,(xml webdav 'supportedlock) ()))))
+  (propstat 200 (list ((xml webdav 'supportedlock)))))
 
 (define-method (set-supportedlock! (self <resource>) _)
   (throw 'protected-resource "supportedlock"))
diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm
index e1bf73fd..95e3d923 100644
--- a/module/calp/webdav/resource/calendar/collection.scm
+++ b/module/calp/webdav/resource/calendar/collection.scm
@@ -30,6 +30,7 @@
 
 ;;; Resoruces containing calendar components
 (define-class <calendar-collection-resource> (<resource>)
+  ;; TODO typecheck
   (description init-value: #f
                accessor: description)
   (data-store getter: data-store
@@ -61,7 +62,7 @@
 
 (define-method (live-properties (self <calendar-collection-resource>))
   (append (next-method)
-          (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair)))
+          (map (lambda (pair) ((xml caldav (car pair)) (cdr pair)))
                caldav-properties)))
 
 
@@ -69,14 +70,14 @@
 
 (define-method (displayname (self <calendar-collection-resource>))
   (propstat 200
-            `((,(xml webdav 'displayname)
-               ,(prop (content self) 'displayname)))))
+            (list ((xml webdav 'displayname)
+                   (prop (content self) 'displayname)))))
 
 
 (define-method (resourcetype (self <calendar-collection-resource>))
   (propstat 200
-   `((,(xml webdav 'resourcetype)
-      (,(xml caldav 'calendar))))))
+            (list ((xml webdav 'resourcetype)
+                   ((xml caldav 'calendar))))))
 
 ;;; CALDAV Properties
 
@@ -84,35 +85,33 @@
   (cond ((description self)
          => (lambda (it)
               (propstat 200
-                        (list (list (xml caldav 'calendar-description (alist->hashq-table '((xml:lang . "en"))))
-                                    it)))))
+                        (list ((xml caldav 'calendar-description '((xml:lang "en")))
+                               it)))))
         (else
-         (propstat 404 (list (list (xml caldav 'calendar-description)))))))
+         (propstat 404 (list ((xml caldav 'calendar-description)))))))
 
 (define-method (calendar-timezone (self <calendar-collection-resource>))
   (propstat 200
             (list
-             (list (xml caldav 'calendar-description)
-                   (call-with-output-string
-                     (lambda (port)
-                       (ics:serialize (base-timezone self) port)))))))
+             ((xml caldav 'calendar-description)
+              (call-with-output-string
+                (lambda (port)
+                  (ics:serialize (base-timezone self) port)))))))
 
 (define-method (supported-calendar-component-set (self <calendar-collection-resource>))
   (propstat 200
-            `((,(xml caldav 'supported-calendar-component-set)
-               (,(xml caldav 'comp
-                      (alist->hashq-table '((name . "VEVENT")))))))))
+            (list ((xml caldav 'supported-calendar-component-set)
+                   ((xml caldav 'comp
+                         '((name "VEVENT"))))))))
 
 (define-method (supported-calendar-data (self <calendar-collection-resource>))
   (propstat 200
    (list
-    (list
-     (xml caldav 'supported-calendar-data)
+    ((xml caldav 'supported-calendar-data)
      (map (lambda (content-type)
-            (list (xml caldav 'calendar-data
-                       (alist->hashq-table
-                        '((content-type . ,content-type)
-                          (version . "2.0"))))))
+            ((xml caldav 'calendar-data
+                  '((content-type ,content-type)
+                    (version "2.0")))))
           '("text/calendar"
             "application/calendar+xml"))))))
 
@@ -128,13 +127,13 @@
 
 (define-method (supported-collation-set (self <calendar-collection-resource>))
   (propstat 200
-            (list `(,(xml caldav 'supported-collation-set)
-                    ,@(map (lambda (cs) `(,(xml caldav 'supported-collation) ,cs))
-                           `(;; Required by CalDAV
-                             "i;ascii-casemap"
-                             "i;octet"
-                             ;; Added (RFC 5051))
-                             "i;unicode-casemap"))))))
+            (list ((xml caldav 'supported-collation-set)
+                   (map (lambda (cs) ((xml caldav 'supported-collation) cs))
+                        `(;; Required by CalDAV
+                          "i;ascii-casemap"
+                          "i;octet"
+                          ;; Added (RFC 5051))
+                          "i;unicode-casemap"))))))
 
 
 
@@ -159,11 +158,11 @@
            ;; Required for ACL, but not for CalDAV
            ;; (xml webdav 'version-tree)
            ;; Optional for ACL, but REQUIRED for CalDAV
-           (cons (xml webdav 'expand-property) expand-property)
+           ((xml webdav 'expand-property) expand-property)
            ;; REQUIRED by CalDAV
-           (cons (xml caldav 'calendar-query) calendar-query)
-           (cons (xml caldav 'calendar-multiget) calendar-multiget)
-           (cons (xml caldav 'free-busy-report) free-busy-report)
+           ((xml caldav 'calendar-query) calendar-query)
+           ((xml caldav 'calendar-multiget) calendar-multiget)
+           ((xml caldav 'free-busy-report) free-busy-report)
            )))
 
 
@@ -196,24 +195,24 @@
     )))
 
     (let ((resources (select-components-by-comp-filter this comp-filter)))
-      `(,(xml webdav 'multistatus)
-        ,@(for (href . resource) in resources
-               `(,(xml webdav 'response)
-                 (,(xml webdav 'href) ,(href->string href))
-                 ,@(map propstat->namespaced-sxml
-                        (merge-propstats
-                         (cond (allprop
-                                (append (propfind-most-live-properties resource)
-                                        (propfind-all-dead-properties resource)))
-                               (propname
-                                (list (propstat
-                                       200
-                                       (map (compose list car)
-                                            (append (dead-properties resource)
-                                                    (live-properties resource))))))
-                               (prop
-                                (map (lambda (prop) (get-property resource prop))
-                                     prop)))))))))))
+      (apply (xml webdav 'multistatus)
+             (for (href . resource) in resources
+                  (apply (xml webdav 'response)
+                         ((xml webdav 'href) (href->string href))
+                         (map propstat->namespaced-sxml
+                                (merge-propstats
+                                 (cond (allprop
+                                        (append (propfind-most-live-properties resource)
+                                                (propfind-all-dead-properties resource)))
+                                       (propname
+                                        (list (propstat
+                                               200
+                                               (map (compose (lambda (x) ((xml x))) car)
+                                                    (append (dead-properties resource)
+                                                            (live-properties resource))))))
+                                       (prop
+                                        (map (lambda (prop) (get-property resource prop))
+                                             prop)))))))))))
 
 
 
@@ -224,10 +223,10 @@
 
 (define-method (calendar-multiget (this <calendar-collection-resource>) request body)
   (define base-href (-> request request-uri uri-path href->string))
-  (let ((allprop  (find-element (xml webdav 'allprop)  (cdr body)))
-        (propname (find-element (xml webdav 'propname) (cdr body)))
-        (prop     (find-element (xml webdav 'prop)     (cdr body)))
-        (hrefs    (find-elements (xml webdav 'href)    (cdr body))))
+  (let ((allprop  (find-children ((xml webdav 'allprop))  (cdr body)))
+        (propname (find-children ((xml webdav 'propname)) (cdr body)))
+        (prop     (find-children ((xml webdav 'prop))     (cdr body)))
+        (hrefs    (find-children ((xml webdav 'href))     (cdr body))))
     (when (< 1 (count identity (list allprop propname prop)))
       (throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive"))
     (when (null? hrefs)
@@ -241,29 +240,30 @@
                       (lookup-resource
                        this
                        (href-relative base-href href))))))
-      `(,(xml webdav 'multistatus)
-        (for (href . resource) in resources
-             `(,(xml webdav 'response)
-               (,(xml webdav 'href) ,(href->string href))
-               ,@(cond (resource
-                        (cond (allprop
-                               (append (propfind-most-live-properties resource)
-                                       (propfind-all-dead-properties resource)))
-                              (propname
-                               (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
-                               (propfind-selected-properties
-                                resource
-                                (map car (cdr prop))))))
-                       (else
-                        `(,(xml webdav 'status)
-                          ,(http-status-line 404))))))))))
+      (apply (xml webdav 'multistatus)
+             (for (href . resource) in resources
+                  (apply (xml webdav 'response)
+                         ((xml webdav 'href) (href->string href))
+                         (cond (resource
+                                (cond (allprop
+                                       (append (propfind-most-live-properties resource)
+                                               (propfind-all-dead-properties resource)))
+                                      (propname
+                                       (list (propstat
+                                              200
+                                              ;; car to get tagname, list to construct a valid xml element
+                                              (map (compose (lambda (x) ((xml x))) car)
+                                                   (append
+                                                    (dead-properties resource)
+                                                    (live-properties resource))))))
+                                      (prop
+                                       (propfind-selected-properties
+                                        resource
+                                        ;; TODO???
+                                        (map car (cdr prop))))))
+                               (else
+                                ((xml webdav 'status)
+                                 (http-status-line 404))))))))))
 
 
 
diff --git a/module/calp/webdav/resource/calendar/object.scm b/module/calp/webdav/resource/calendar/object.scm
index 82a8c18e..0f59ced7 100644
--- a/module/calp/webdav/resource/calendar/object.scm
+++ b/module/calp/webdav/resource/calendar/object.scm
@@ -19,6 +19,7 @@
 ;;; content%
 
 (define-class <calendar-object-resource> (<resource>)
+  ;; TODO typecheck
   (component getter: component
              init-keyword: component:))
 
diff --git a/module/calp/webdav/resource/file.scm b/module/calp/webdav/resource/file.scm
index e2fec9a5..0d85098c 100644
--- a/module/calp/webdav/resource/file.scm
+++ b/module/calp/webdav/resource/file.scm
@@ -4,6 +4,7 @@
   :use-module (hnh util)
   :use-module (hnh util env)
   :use-module (hnh util path)
+  :use-module (hnh util type)
   :use-module (datetime)
   :use-module (ice-9 popen)
   :use-module (ice-9 rdelim)
@@ -27,6 +28,11 @@
   (root getter: root setter: set-root! init-value: "/" init-keyword: root:)
   (path getter: path setter: set-path! init-value: "/" init-keyword: path:))
 
+(define-method (initialize (self <file-resource>) args)
+  (next-method)
+  (typecheck (root self) string? "<file-resource>.root")
+  (typecheck (path self) string? "<file-resource>.path"))
+
 (define-method (write (self <file-resource>) port)
   (display
    (format #f "#<<file-resource> name=~s, root=~s, path=~s>"
diff --git a/module/calp/webdav/resource/virtual.scm b/module/calp/webdav/resource/virtual.scm
index 42ffc123..047336c5 100644
--- a/module/calp/webdav/resource/virtual.scm
+++ b/module/calp/webdav/resource/virtual.scm
@@ -3,6 +3,7 @@
   :use-module (datetime)
   :use-module (rnrs bytevectors)
   :use-module (hnh util)
+  :use-module (hnh util type)
   :use-module (sxml namespaced)
   :use-module (sxml namespaced util)
   :use-module (calp webdav resource)
@@ -26,6 +27,11 @@
                  init-keyword: creation-time:
                  getter: creation-time))
 
+(define-method (initialize (self <virtual-resource>) args)
+  (next-method)
+  (typecheck (content* self) bytevector? "<virtual-resource>.content*")
+  (typecheck (creation-time self) datetime? "<virtual-resource>.creation-time"))
+
 (define (virtual-resource? x)
   (is-a? x <virtual-resource>))
 
@@ -38,7 +44,7 @@
 (define-method (live-properties (self <virtual-resource>))
   (append
    (next-method)
-   (list (cons (xml-element-hash-key (xml virtual-ns 'isvirtual))
+   (list (cons ((xml virtual-ns 'isvirtual))
                (make-live-property isvirtual set-isvirtual!)))))
 
 (define-method (content (self <virtual-resource>))
@@ -50,22 +56,22 @@
 (define-method (creationdate (self <virtual-resource>))
   (propstat 200
             (list
-             (list (xml webdav 'creationdate)
-                   (-> (creation-time self)
-                       (datetime->string "~Y-~m-~dT~H:~M:~SZ"))))))
+             ((xml webdav 'creationdate)
+              (-> (creation-time self)
+                  (datetime->string "~Y-~m-~dT~H:~M:~SZ"))))))
 
 
 (define-method (getcontenttype (self <resource>))
   (propstat 200
             (list
-             (list (xml webdav 'getcontenttype)
-                   "application/binary"))))
+             ((xml webdav 'getcontenttype)
+              "application/binary"))))
 
 (define-method (isvirtual (self <virtual-resource>))
   (propstat 200
             (list
-             (list (xml virtual-ns 'isvirtual)
-                   "true"))))
+             ((xml virtual-ns 'isvirtual)
+              "true"))))
 
 
 (define-method (set-isvirtual! (self <virtual-resource>) _)
diff --git a/module/hnh/util/table.scm b/module/hnh/util/table.scm
index 94d3c110..2c174448 100644
--- a/module/hnh/util/table.scm
+++ b/module/hnh/util/table.scm
@@ -51,6 +51,7 @@
 (define-type (tree-terminal printer: (lambda (_ p) (write '(table) p))))
 
 ;; Wrapped for better error messages
+;;; TODO possibly only have one tree-terminal shared by everyone
 (define (make-tree) (tree-terminal))
 
 (define (tree? x)
diff --git a/module/sxml/namespaced.scm b/module/sxml/namespaced.scm
index 1c2eb322..82a137c5 100644
--- a/module/sxml/namespaced.scm
+++ b/module/sxml/namespaced.scm
@@ -24,6 +24,7 @@
 
            xml-element
            xml-element?
+           xml-element*?
            xml-element-tagname
            xml-element-namespace
            xml-element-attributes
@@ -39,6 +40,7 @@
            pi-body
            ))
 
+
 (define (car+cadr p) (values (car p) (cadr p)))
 (define (2list->pair l)
   (call-with-values (lambda () (car+cadr l)) cons))
@@ -66,14 +68,16 @@
                 ns:  ,(xml-element-namespace el)
                 attributes: ,(serialize-table (xml-element-attributes el))
                 children: (list ,@(map (lambda (e)
-                                         (cond ((xml-element? e)
+                                         (cond ((xml-element*? e)
                                                 (serialize-xml-element e))
                                                (else e)))
                                        (xml-element-children el)))))
 
-(define-type (xml-element printer: (lambda (r p)
-                                     (pretty-print (serialize-xml-element r)
-                                                   p)))
+
+(define-type (xml-element
+              printer: (lambda (r p)
+                         (pretty-print (serialize-xml-element r)
+                                       p)))
   (xml-element-tagname    type: symbol?
                           keyword: tag)
   (xml-element-namespace  type: (or false? symbol?)
@@ -91,8 +95,15 @@
                           default: '()))
 
 
+;;; NOTE Due to how define-type works, and how guile expands forms,
+;;; this MUST be placed after the xml-element declaration. Otherwise
+;;; `xml-element?' is of type syntax-transformer, which isn't a procedure.
+(define (xml-element*? x)
+  (xml-element? x))
+
+
 (define-type (xml-document)
-  (xml-document-root type: xml-element?
+  (xml-document-root type: xml-element*?
                      keyword: root)
   (xml-document-pis  type: (list-of pi-element?)
                      keyword: pi
@@ -104,7 +115,7 @@
     ((tag)          (lambda children (xml-element children: children tag: tag)))
     ((ns tag)       (lambda children (xml-element children: children tag: tag ns: ns)))
     ((ns tag attrs) (lambda children (xml-element children: children tag: tag ns: ns
-                                             attributes: (attributes->table attrs))))))
+                                                  attributes: (attributes->table attrs))))))
 
 (define (attribute xml attr)
   (assoc-ref (xml-element-attributes xml) attr))
@@ -162,7 +173,7 @@
    (lambda (elem-gi attributes namespaces parent-seed seed)
      (let ((head tail (pop seed)))
        (modify tail
-               (find* xml-element?)
+               (find* xml-element*?)
                (lambda (parent)
                  (add-child
                   (modify head xml-element-children* reverse)
@@ -174,9 +185,9 @@
        (if trim-whitespace?
            (string-trim-both (string-append s1 s2))
            (string-append s1 s2)))
-     (if (null? s)
+     (if (string-null? s)
          seed
-         (modify seed (lens-compose (find* xml-element?)
+         (modify seed (lens-compose (find* xml-element*?)
                                     xml-element-children*)
                  (lambda (ch) (cons s ch)))))
 
@@ -185,7 +196,7 @@
    ((*DEFAULT* . (lambda (port pi-tag seed)
                    (let ((body (ssax:read-pi-body-as-string port)))
                      (modify seed
-                             (find* xml-element?)
+                             (find* xml-element*?)
                              (lambda (parent)
                                (add-child (pi-element pi-tag body)
                                           parent)))))))))
@@ -196,11 +207,11 @@
     (with-ssax-error-to-port
      (current-error-port)
      (lambda () ((parser trim-whitespace?: trim-whitespace?)
-            (->port port-or-string)
-            (list ((xml 'ROOT)))))))
+                 (->port port-or-string)
+                 (list ((xml 'ROOT)))))))
 
   (let ((roots pis
-               (partition xml-element?
+               (partition xml-element*?
                           (-> result peek xml-element-children))))
     (xml-document
      root: (car roots)
@@ -277,13 +288,13 @@
 
 (define (namespaced-sxml->sxml* tree)
   (cond ((string? tree)      (return tree))
-        ((xml-element? tree) (xml-element->sxml tree))
+        ((xml-element*? tree) (xml-element->sxml tree))
         ((pi-element? tree)  (return (pi-element->sxml tree)))
         ((xml-document? tree)
          (do pis <- (sequence (map namespaced-sxml->sxml*
                                    (xml-document-pis tree)))
              el  <- (namespaced-sxml->sxml*
-                     (xml-document-root tree))
+                    (xml-document-root tree))
              (return `(*TOP* ,@pis ,el))))
         (else (scm-error 'misc-error "namespaced-sxml->sxml*"
                          "Unexpected token in tree: ~s"
@@ -326,7 +337,7 @@
     (('*TOP* rest ...)
      (let ((groups
             (group-by (lambda (x)
-                        (cond ((xml-element? x) 'el)
+                        (cond ((xml-element*? x) 'el)
                               ((pi-element?  x) 'pi)
                               (else #f)))
                       (map (lambda (r) (sxml->namespaced-sxml r namespaces))
@@ -362,4 +373,3 @@
 ;;; TODO Figure out how to still use (sxml match) and (sxml xpath) with these
 ;;;      new trees (probably rewriting to a "regular" sxml tree, and keeping
 ;;;      a strict mapping of namespaces)
-
diff --git a/module/sxml/namespaced/util.scm b/module/sxml/namespaced/util.scm
index 9a4e72d7..e60254b7 100644
--- a/module/sxml/namespaced/util.scm
+++ b/module/sxml/namespaced/util.scm
@@ -2,6 +2,7 @@
   :use-module (sxml namespaced)
   :use-module (srfi srfi-1)
   :use-module ((ice-9 control) :select (call/ec))
+  :use-module (hnh util type)
   :export (xml-element-hash-key
            find-child
            element-matches?
@@ -14,6 +15,8 @@
         (xml-element-tagname tag)))
 
 (define (find-child target list)
+  (typecheck target xml-element?)
+  (typecheck list (list-of (or xml-element? string?)))
   (define target* (xml-element-hash-key target))
   (find (lambda (x) (and (xml-element? x)
                     (equal? target* (xml-element-hash-key x))))
diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm
index 8fadde75..a0c8620d 100644
--- a/module/vcomponent/formats/xcal.scm
+++ b/module/vcomponent/formats/xcal.scm
@@ -23,6 +23,9 @@
 (define* (deserialize port)
   (-> port
       xml->namespaced-sxml
-      root-element                      ; Strip potential *TOP*
-      cadr                              ; Remove containing icalendar
+      xml-document-root
+
+      ;; Remove containing icalendar
+      xml-element-children car
+
       sxcal->vcomponent))
diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm
index a5f8a934..f0c11a4e 100644
--- a/module/vcomponent/formats/xcal/output.scm
+++ b/module/vcomponent/formats/xcal/output.scm
@@ -59,9 +59,10 @@
 
     [(memv k '(GEO))
      (lambda (_ v)
-       `(,(xml xcal 'geo)
-         (latitude ,(geo-latitude v))
-         (longitude ,(geo-longitude v))))]
+       ((xml xcal 'geo)
+        (list
+         ((xml xcal 'latitude)  (geo-latitude v))
+         ((xml xcal 'longitude) (geo-longitude v)))))]
 
     [(memv k '(RRULE))
      (get-writer 'RECUR)]
@@ -84,60 +85,59 @@
   (if (or (eq? tag 'VALUE)
           (internal-field? tag))
       #f
-      `(,(xml xcal (downcase-symbol tag))
-        ,@(map (lambda (v)
-                 ;; TODO parameter types!!!! (rfc6321 3.5.)
-                 `(,(xml xcal 'text) ,(->string v)))
-               value))))
+      (apply (xml xcal (downcase-symbol tag))
+             (map (lambda (v)
+                    ;; TODO parameter types!!!! (rfc6321 3.5.)
+                    ((xml xcal 'text) (->string v)))
+                  value))))
 
-;; ((key value ...) ...) -> `(parameters , ... )
+;; ((key value ...) ...) -> #<xml parameters>
 (define (parameters-tag parameters)
   (define outparams (filter-map
                      (lambda (x) (property->value-tag x))
                      parameters))
 
-  (unless (null? outparams)
-    `(,(xml xcal 'parameters) ,@outparams)))
+  (apply (xml xcal 'parameters) outparams))
 
 (define (vcomponent->sxcal component)
 
   (define tagsymb (downcase-symbol (type component)))
 
-  (remove null?
-   `(,(xml xcal tagsymb)
-     ;; only have <properties> when it's non-empty.
-     ,(let ((props
-             (filter-map
-              (match-lambda
-                [(? (compose internal-field? car)) #f]
-
-                [(key (vlines ...))
-                 (remove null?
-                         `(,(xml xcal (downcase-symbol key))
-                           ,(parameters-tag (reduce assq-merge
-                                                    '()
-                                                    (map parameters vlines)))
-                           ,@(for vline in vlines
-                                  (vline->value-tag vline))))]
-
-                [(key vline)
-                 (remove null?
-                         `(,(xml xcal (downcase-symbol key))
-                           ,(parameters-tag (parameters vline))
-                           ,(vline->value-tag vline)))])
-              ;; NOTE this sort is unnecesasary, but here so tests can work
-              ;; Possibly add it as a flag instead
-              (sort* (properties component)
-                     string< (compose symbol->string car)))))
-        (unless (null? props)
-          `(,(xml xcal 'properties)
-            ;; NOTE
-            ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME)))
-            ,@props)))
-     ,(unless (null? (children component))
-        `(,(xml xcal 'components)
-          ,@(map vcomponent->sxcal (children component)))))))
+  (apply (xml xcal tagsymb)
+         (remove (compose null? xml-element-children)
+                 ;; only have <properties> when it's non-empty.
+                 (list
+                  (let ((props
+                         (filter-map
+                          (match-lambda
+                            [(? (compose internal-field? car)) #f]
+
+                            [(key (vlines ...))
+                             (apply (xml xcal (downcase-symbol key))
+                                    (remove (compose null? xml-element-children)
+                                            (cons
+                                             (parameters-tag (reduce assq-merge
+                                                                     '()
+                                                                     (map parameters vlines)))
+                                             (map vline->value-tag vlines))))]
+
+                            [(key vline)
+                             (apply (xml xcal (downcase-symbol key))
+                                    (remove (compose null? xml-element-children)
+                                            (list
+                                             (parameters-tag (parameters vline))
+                                             (vline->value-tag vline))))])
+                          ;; NOTE this sort is unnecesasary, but here so tests can work
+                          ;; Possibly add it as a flag instead
+                          (sort* (properties component)
+                                 string< (compose symbol->string car)))))
+                    (apply (xml xcal 'properties)
+                           ;; NOTE
+                           ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME)))
+                           props))
+                  (apply (xml xcal 'components)
+                         (map vcomponent->sxcal (children component)))))))
 
 (define (ns-wrap sxml)
-  `(,(xml xcal 'icalendar)
-    ,sxml))
+  ((xml xcal 'icalendar)
+   sxml))
diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm
index 812f1d20..b9b8239d 100644
--- a/module/vcomponent/formats/xcal/types.scm
+++ b/module/vcomponent/formats/xcal/types.scm
@@ -9,32 +9,33 @@
   :export (get-writer))
 
 (define (write-boolean _ v)
-  `(,(xml xcal 'boolean) ,(if v "true" "false")))
+  ((xml xcal 'boolean) (if v "true" "false")))
 
 (define (write-date _ v)
-  `(,(xml xcal 'date) ,(date->string v "~Y-~m-~d")))
+  ((xml xcal 'date) (date->string v "~Y-~m-~d")))
 
 (define (write-datetime p v)
-  `(,(xml xcal 'date-time)
-    ,(datetime->string
-      (table-get p '-X-HNH-ORIGINAL v)
-      ;; 'Z' should be included for UTC,
-      ;; other timezones MUST be specified
-      ;; in the TZID parameter.
-      "~Y-~m-~dT~H:~M:~S~Z")))
+  ((xml xcal 'date-time)
+   (datetime->string
+    (table-get p '-X-HNH-ORIGINAL v)
+    ;; 'Z' should be included for UTC,
+    ;; other timezones MUST be specified
+    ;; in the TZID parameter.
+    "~Y-~m-~dT~H:~M:~S~Z")))
 
 (define (write-time _ v)
-  `(,(xml xcal 'time) ,(time->string v "~H:~M:S")))
+  ((xml xcal 'time) (time->string v "~H:~M:S")))
 
 (define (write-recur _ v)
-  `(,(xml xcal 'recur) ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v)))
+  (apply (xml xcal 'recur)
+         ((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v)))
 
 ;; sepparate since this text shouldn't be escaped
 (define (write-text _ v)
   ;; TODO out type should be xsd:string.
   ;; Look into what that means, and escape
   ;; from there
-  `(,(xml xcal 'text) ,v))
+  ((xml xcal 'text) v))
 
 
 
@@ -43,8 +44,9 @@
                              #| TODO PERIOD |# URI UTC-OFFSET)
      (hashq-set! sxml-writers simple-type
                  (lambda (p v)
-                   `(,(xml xcal (downcase-symbol simple-type))
-                     ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v)))))
+                   ((xml xcal (downcase-symbol simple-type))
+                    (((@ (vcomponent formats ical types) get-writer) simple-type)
+                     p v)))))
 
 (hashq-set! sxml-writers 'BOOLEAN write-boolean)
 (hashq-set! sxml-writers 'DATE write-date)
diff --git a/testrunner.scm b/testrunner.scm
index 8abea1e2..a757fdee 100755
--- a/testrunner.scm
+++ b/testrunner.scm
@@ -183,7 +183,12 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
                 (lambda args
                   (enqueue! (format-test-runner-crash-message args)
                             error-queue)
-                  (values #f '()))))
+                  (values #f '()))
+                (lambda _
+                  ;; TODO make backtrace configurable
+                  ;; TODO backtrace should be placed AFTER the error
+                  (enqueue! (with-output-to-string (lambda () (backtrace))) error-queue)
+                  )))
             (catch 'wrong-type-arg
               (lambda () (typecheck module-names (list-of (list-of symbol?))))
               (lambda (_ __ fmt args ___)
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*"))