5 files changed, 925 insertions, 0 deletions
diff --git a/tests/litmus.scm b/tests/litmus.scm
new file mode 100755
index 00000000..11d5fd9e
--- /dev/null
+++ b/tests/litmus.scm
@@ -0,0 +1,80 @@
+#!/usr/bin/env bash
+# -*- mode: scheme; geiser-scheme-implementation: guile -*-
+
+here=$(dirname $(realpath $0))
+. "$(dirname "$here")/env"
+
+exec $GUILE -e main -s "$0" "$@"
+!#
+
+(use-modules (calp server webdav)
+             (ice-9 threads)
+             (ice-9 rdelim)
+             (web server)
+             (srfi srfi-1)
+             (srfi srfi-88))
+
+;;; Commentary:
+;;; Runs the external WebDAV test framework litmus [1], pointing it
+;;; to a new instance of our webdav server.
+;;;
+;;; [1]: http://webdav.org/neon/litmus/
+;;;
+;;; Code:
+
+
+;;; NOTE this "page" is borrowed from (calp server server).
+;;; Possibly rewrite so that module actually works as a module,
+;;; And import it here
+
+
+;; NOTE The default make-default-socket is broken for IPv6.
+;; A patch has been submitted to the mailing list. 2020-03-31
+;;
+;; This sets up the socket manually, and sends that to @code{http-open}.
+(define* (make-default-socket/fixed family addr port)
+  (let ((sock (socket family SOCK_STREAM 0)))
+    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (bind sock family addr port)
+    sock))
+
+(define* (setup-socket key:
+                       (host #f)
+                       (family AF_INET)
+                       (addr (if host (inet-pton family host)
+                                 INADDR_LOOPBACK))
+                       (port 8080))
+  (make-default-socket/fixed family addr port))
+
+
+
+(define (start-server out)
+  (begin-thread
+   (let loop ((port 8102))
+     (catch 'system-error
+       (lambda ()
+         (let ((socket (setup-socket port: port)))
+           (format out "http://localhost:8102~%")
+           (force-output out)
+           (with-error-to-file "webdav.log"
+             (lambda ()
+               (run-server webdav-handler 'http
+                           `(socket: ,socket))))
+           (format #t "Server closed~%")))
+       (lambda (err proc fmt args data)
+         (if (= EADDRINUSE (car data))
+             (loop (1+ port))
+             (apply throw err proc fmt args data)))))))
+
+
+(define (main args)
+  (define-values (in out) (car+cdr (pipe)))
+  (define scm (start-server out))
+  (define uri-base (read-line in))
+  (define suffix
+    (if (null? (cdr args))
+        ""
+        (string-append "/" (cadr args))))
+  (system* "litmus" (string-append uri-base suffix))
+
+  (cancel-thread scm))
diff --git a/tests/test/webdav-file.scm b/tests/test/webdav-file.scm
new file mode 100644
index 00000000..4096016b
--- /dev/null
+++ b/tests/test/webdav-file.scm
@@ -0,0 +1,53 @@
+(define-module (test webdav-file)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (hnh util)
+  :use-module (hnh util path)
+  :use-module (ice-9 ftw)
+  :use-module (ice-9 rdelim)
+  :use-module (oop goops)
+  :use-module (calp webdav resource)
+  :use-module (calp webdav resource file)
+  )
+
+;;; Commentary:
+;;; Tests the specifics of the file backed webdav resource objects.
+;;; Code:
+
+
+;;; TODO general helper procedure for this
+(define test-root (mkdtemp (string-copy "/tmp/calp-test-XXXXXX")))
+
+(define root-resource (make <file-resource>
+                        root: test-root))
+
+
+(test-group "File resource collection"
+  (add-collection! root-resource "subdir")
+  (test-eqv "Collection correctly added"
+    'directory (-> (path-append test-root "subdir")
+                   stat stat:type) ))
+
+
+
+;;; TODO this fails, sice <file-resource> doesn't override add-resource!
+;;; <file-resources>'s add resource must at least update root path path of the
+;;; child resource, and possibly also touch the file (so ctime gets set).
+(test-group "File resource with content"
+  (let ((fname "file.txt")
+        (s "Hello, World!\n"))
+    (add-resource! root-resource fname s)
+    (let ((p (path-append test-root fname)))
+      (test-eqv "File correctly added"
+        'regular (-> p stat stat:type))
+      (test-equal "Expected content was written"
+        s
+        (with-input-from-file p
+          (lambda () (read-delimited "")))
+        ))))
+
+
+
+(test-group "Copy file"
+  'TODO)
diff --git a/tests/test/webdav-server.scm b/tests/test/webdav-server.scm
new file mode 100644
index 00000000..64a9e144
--- /dev/null
+++ b/tests/test/webdav-server.scm
@@ -0,0 +1,349 @@
+(define-module (test webdav-server)
+  ;; :use-module (srfi srfi-1)
+  ;; :use-module (ice-9 threads)
+
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (calp server webdav)
+  :use-module (calp webdav resource)
+  :use-module ((calp webdav property) :select (propstat))
+  :use-module (calp webdav resource virtual)
+  :use-module (calp namespaces)
+  :use-module (oop goops)
+  :use-module (web request)
+  :use-module (web response)
+  :use-module (web uri)
+  :use-module (sxml simple)
+  :use-module (sxml xpath)
+  :use-module (sxml namespaced)
+  :use-module (hnh util)
+  )
+
+;;; Commentary:
+;;; Tests that handlers for all HTTP Methods works correctly.
+;;; Note that these tests don't have as goal to check that resources and
+;;; properties work correctly. See (test webdav) and (test webdav-tree) for that.
+;;;
+;;; The namespaces http://ns.example.com/properties is intentionally given
+;;; different prefixes everywhere, to ensure that namespaces are handled correctly.
+;;; Code:
+
+(define prop-ns (string->symbol "http://ns.example.com/properties"))
+
+(root-resource (make <virtual-resource> name: "*root*"))
+(add-resource! (root-resource) "a" "Contents of A")
+(add-resource! (root-resource) "b" "Contents of B")
+
+;;; Connect output of one procedure to input of another
+;;; Both producer and consumer should take exactly one port as argument
+(define (connect producer consumer)
+  ;; (let ((in out (car+cdr (pipe))))
+  ;;   (let ((thread (begin-thread (consumer in))))
+  ;;     (producer out)
+  ;;     (join-thread thread)))
+
+  (call-with-input-string
+      (call-with-output-string producer)
+    consumer))
+
+(define (xml->sxml* port)
+  (xml->sxml port namespaces: `((d . ,(symbol->string webdav))
+                                (y . ,(symbol->string prop-ns)))))
+
+
+
+(test-group "run-propfind"
+  (test-group "Working, depth 0"
+   (let* ((request (build-request
+                    (string->uri "http://localhost/")
+                    method: 'PROPFIND
+                    headers: '((depth . 0))
+                    validate-headers?: #f))
+          (head body (run-propfind '() request #f)))
+     (test-equal 207 (response-code head))
+     (test-equal '(application/xml)
+       (response-content-type head))
+     (test-assert (procedure? body))
+     (let ((body* (connect body xml->sxml*)))
+       ;; Arbitrarily chosen resource
+       (test-equal "Resource gets returned as expected"
+           '((d:resourcetype (d:collection)))
+         ((sxpath '(// d:response
+                       (d:propstat (// d:status (equal? "HTTP/1.1 200 OK")))
+                       // d:resourcetype))
+          body*)))))
+
+  (test-group "Depth: infinity"
+    (let* ((request (build-request
+                     (string->uri "http://localhost/")
+                     method: 'PROPFIND
+                     headers: '((depth . infinity))
+                     validate-headers?: #f))
+           (head body (run-propfind '() request #f)))
+      (test-equal 207 (response-code head))
+      (test-equal '(application/xml) (response-content-type head))
+      (test-assert (procedure? body))
+      (let ((body* (connect body xml->sxml*)))
+        (test-equal
+            '("/" "/a" "/b")
+          (sort* ((sxpath '(// d:href *text*)) body*)
+                 string<)))))
+
+  (test-group "With body"
+    (let ((request (build-request (string->uri "http://localhost/")
+                                  method: 'PROPFIND
+                                  headers: '((depth . 0))
+                                  validate-headers?: #f))
+          (request-body "<?xml version=\"1.0\" encoding=\"utf-8\"?>
+<propfind xmlns=\"DAV:\">
+  <prop><resourcetype/></prop>
+</propfind>"))
+      (let ((head body (run-propfind '() request request-body)))
+        (test-equal 207 (response-code head))
+        (test-equal '(application/xml) (response-content-type head))
+        (test-assert (procedure? body))
+        (let ((body* (connect body xml->sxml*)))
+          (test-equal "We only get what we ask for"
+            '((d:prop (d:resourcetype (d:collection))))
+            ((sxpath '(// d:response
+                          (d:propstat (// d:status (equal? "HTTP/1.1 200 OK")))
+                          // d:prop))
+             body*)))))))
+
+
+
+(test-group "run-proppatch"
+  (let ((request (build-request (string->uri "http://localhost/a")
+                                method: 'PROPPATCH))
+        (request-body (format #f "<?xml version=\"1.0\" encoding=\"utf-8\"?>
+<propertyupdate xmlns=\"DAV:\" xmlns:x=\"~a\">
+  <set>
+    <prop>
+      <displayname>New Displayname</displayname>
+      <x:test><x:content/></x:test>
+    </prop>
+  </set>
+  <!-- TODO test remove? -->
+</propertyupdate>" prop-ns)))
+    (let ((response body (run-proppatch '("a") request request-body)))
+      (test-equal 207 (response-code response))
+      (test-equal '(application/xml) (response-content-type response))
+      (test-assert (procedure? body))
+      ;; Commit the changes
+      (call-with-output-string body)
+      ))
+
+  (let ((response body (run-propfind
+                        '("a")
+                        (build-request (string->uri "http://localhost/a")
+                                       method: 'PROPFIND
+                                       headers: '((depth . 0))
+                                       validate-headers?: #f)
+                                     (format #f "<?xml version=\"1.0\" encoding=\"utf-8\"?>
+<propfind xmlns=\"DAV:\" xmlns:z=\"~a\">
+  <prop>
+    <displayname/>
+    <z:test/>
+  </prop>
+</propfind>" prop-ns))))
+    (test-equal 207 (response-code response))
+    (test-equal '(application/xml) (response-content-type response))
+    (test-assert (procedure? body))
+
+    ;; (format (current-error-port) "Here~%")
+    ;; ;; The crash is after here
+    ;; (body (current-error-port))
+
+    (let* ((body* (connect body xml->sxml*))
+           (properties ((sxpath '(// d:response
+                                     (d:propstat (// d:status (equal? "HTTP/1.1 200 OK")))))
+                        body*)))
+      ;; ((@ (ice-9 format) format) (current-error-port) "Properties: ~y~%" properties)
+      (test-equal "Native active property is properly updated"
+        '("New Displayname")
+        ((sxpath '(// d:displayname *text*)) properties))
+      (test-equal "Custom property is correctly stored and preserved"
+        '((y:test (y:content)))
+        ((sxpath '(// y:test)) properties))))
+
+  ;; TODO test proppatch atomicity
+  )
+
+
+
+(test-group "run-options"
+  (let ((head body (run-options #f #f)))
+    (test-equal "options head"
+      (build-response
+       code: 200
+       headers: `((dav . (1))
+                  (allow . (GET HEAD PUT MKCOL PROPFIND OPTIONS DELETE COPY MOVE))))
+      head)
+    (test-equal "options body"
+      "" body)))
+
+
+
+(test-group "run-get"
+  (let ((head body (run-get '("a")
+                            (build-request
+                             (string->uri "http://localhost/a")
+                             method: 'GET)
+                            'GET)))
+    (test-equal "Contents of A" body)))
+
+
+
+(test-group "run-put"
+  (test-group "Update existing resource"
+    (run-put '("a")
+             (build-request (string->uri "http://localhost/a")
+                            method: 'PUT
+                            port: (open-output-string))
+             "New Contents of A")
+
+    (let ((head body (run-get '("a")
+                              (build-request
+                               (string->uri "http://localhost/a")
+                               method: 'GET)
+                              'GET)))
+      (test-equal "Put updates subsequent gets"
+        "New Contents of A" body)))
+
+  (test-group "Create new resource"
+    (run-put '("c")
+             (build-request (string->uri "http://localhost/c")
+                            method: 'PUT
+                            port: (open-output-string))
+             "Created Resource C")
+    (let ((head body (run-get '("c")
+                              (build-request
+                               (string->uri "http://localhost/c")
+                               method: 'GET)
+                              'GET)))
+      (test-equal "Put creates new resources"
+        "Created Resource C" body))))
+
+
+
+;;; Run DELETE
+(test-group "run-delete"
+  'TODO)
+
+
+
+
+(test-group "run-mkcol"
+  (run-mkcol '("a" "b")
+             (build-request (string->uri "http://localhost/a/b")
+                            method: 'MKCOL)
+             "")
+  (let* ((request (build-request
+                   (string->uri "http://localhost/")
+                   method: 'PROPFIND
+                   headers: '((depth . infinity))
+                   validate-headers?: #f))
+         (head body (run-propfind '() request #f)))
+    (test-equal 207 (response-code head))
+    (test-equal '(application/xml) (response-content-type head))
+    (test-assert (procedure? body))
+    (let ((body* (connect body xml->sxml*)))
+      (test-equal "Check that all created resources now exists"
+        '("/" "/a" "/a/b" "/b" "/c")
+        (sort* ((sxpath '(// d:href *text*)) body*)
+               string<)))))
+
+
+;;; TODO test MKCOL indempotence
+
+
+
+;;; Run COPY
+(test-group "run-copy"
+  (parameterize ((root-resource (make <virtual-resource> name: "*root*")))
+    (add-resource! (root-resource) "a" "Content of A")
+    (let ((a (lookup-resource (root-resource) '("a"))))
+      (set-property! a `(,(xml prop-ns 'test) "prop-value")))
+
+    (test-group "cp /a /c"
+      (let ((response _
+                      (run-copy '("a")
+                                (build-request
+                                 (string->uri "http://example.com/a")
+                                 headers: `((destination
+                                             . ,(string->uri "http://example.com/c")))))))
+        ;; Created
+        (test-eqv "Resource was reported created"
+          201 (response-code response)))
+
+      (let ((c (lookup-resource (root-resource) '("c"))))
+        (test-assert "New resource present in tree" c)
+        (test-equal "Content was correctly copied"
+          "Content of A" (content c))
+        (test-equal "Property was correctly copied"
+          (propstat 200
+                    (list `(,(xml prop-ns 'test)
+                            "prop-value")))
+          (get-property c (xml prop-ns 'test)))))
+
+    (test-group "cp --no-clobber /c /a"
+      (let ((response _
+                      (run-copy '("c")
+                                (build-request
+                                 (string->uri "http://example.com/c")
+                                 headers: `((destination
+                                             . ,(string->uri "http://example.com/a"))
+                                            (overwrite . #f))))))
+        ;; collision
+        (test-eqv "Resource collision was reported"
+          412 (response-code response))))
+
+    ;; Copy recursive collection, and onto child of self.
+    (test-group "cp -r / /c"
+      (let ((response _
+             (run-copy '()
+                       (build-request
+                        (string->uri "http://example.com/")
+                        headers: `((destination . ,(string->uri "http://example.com/c")))))))
+        (test-eqv "Check that reported replaced"
+          204 (response-code response))
+        (test-equal "Check that recursive resources where created"
+          '("/" "/a" "/c"
+            ;; New resources. Note that /c/c doesn't create an infinite loop
+            "/c/a" "/c/c")
+          (map car
+           (sort* (map (lambda (p) (cons (href->string (car p)) (cdr p)))
+                       (all-resources-under (root-resource) '()))
+                  string< car)))
+
+        ;; TODO we should also check that /c is a copy of the root resource,
+        ;; instead of the old /c resource.
+        ;; Do this by setting some properties
+        ))))
+
+
+
+;;; Run MOVE
+(test-group "run-move"
+  (parameterize ((root-resource (make <virtual-resource> name: "*root*")))
+    (add-resource! (root-resource) "a" "Content of A")
+    (let ((a (lookup-resource (root-resource) '("a"))))
+      (set-property! a `(,(xml prop-ns 'test) "prop-value")))
+
+    (test-group "mv /a /c"
+      (let ((response _
+                      (run-move '("a")
+                                (build-request
+                                 (string->uri "http://example.com/a")
+                                 headers: `((destination
+                                             . ,(string->uri "http://example.com/c")))))))
+        ;; Created
+        (test-eqv "Resource was reported created"
+          201 (response-code response))
+        ;; TODO check that old resource is gone
+        ))))
+
+
+
+;;; Run REPORT
diff --git a/tests/test/webdav-tree.scm b/tests/test/webdav-tree.scm
new file mode 100644
index 00000000..5c2a6a9b
--- /dev/null
+++ b/tests/test/webdav-tree.scm
@@ -0,0 +1,89 @@
+(define-module (test webdav-tree)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (calp webdav resource)
+  :use-module (calp webdav resource virtual)
+  :use-module (calp webdav resource file)
+  :use-module (oop goops)
+  :use-module (rnrs bytevectors)
+  :use-module (rnrs io ports)
+  :use-module ((hnh util) :select (sort*))
+  :use-module (hnh util path)
+  )
+
+(define* (pretty-print-tree tree
+                            optional: (formatter (lambda (el) (write el) (newline)))
+                            key: (depth 0))
+  (cond ((null? tree) 'noop)
+        ((pair? tree)
+         (display (make-string (* depth 2) #\space)) (formatter (car tree))
+         (for-each (lambda (el) (pretty-print-tree el formatter depth: (+ depth 1)))
+                   (cdr tree)))
+        (else (formatter tree))))
+
+(define-method (resource-tree (self <resource>))
+  (cons self
+        (map resource-tree (children self))))
+
+
+
+(define dir (mkdtemp (string-copy "/tmp/webdav-tree-XXXXXX")))
+(with-output-to-file (path-append dir "greeting")
+  (lambda () (display "Hello, World!\n")))
+
+(define root-resource (make <virtual-resource>
+                        name: "*root*"))
+
+(define virtual-resource (make <virtual-resource>
+                           name: "virtual"
+                           content: (string->bytevector "I'm Virtual!" (native-transcoder))))
+
+(define file-tree (make <file-resource>
+                    root: dir
+                    name: "files"))
+
+(mount-resource! root-resource file-tree)
+(mount-resource! root-resource virtual-resource)
+
+(test-equal "All resources in tree, along with href items"
+    (list (cons '() root-resource)
+          (cons '("files") file-tree)
+          (cons '("files" "greeting") (car (children file-tree)))
+          (cons '("virtual") virtual-resource))
+  (sort* (all-resources-under root-resource) string< (compose string-concatenate car)))
+
+
+
+;; (pretty-print-tree (resource-tree root-resource))
+
+
+
+;; (test-equal '("") (href root-resource) )                 ; /
+;; ;; (test-equal '("" "virtual") (href virtual-resource))     ; /virtual & /virtual/
+;; (test-equal '("virtual") (href virtual-resource))  ; /virtual & /virtual/
+;; ;; (test-equal '("" "files") (href file-tree))              ; /files & /files/
+;; (test-equal '("files") (href file-tree))           ; /files & /files/
+
+(test-eqv "Correct amount of children are mounted"
+  2 (length (children root-resource)))
+
+(test-eq "Lookup root"
+  root-resource (lookup-resource root-resource '()))
+
+(test-eq "Lookup of mount works (virtual)"
+  virtual-resource (lookup-resource root-resource '("virtual")))
+(test-eq "Lookup of mount works (files)"
+  file-tree (lookup-resource root-resource '("files")))
+
+;; (test-equal "File resource works as expected"
+;;   "/home/hugo/tmp"
+;;   (path file-tree))
+
+(let ((resource (lookup-resource root-resource (string->href "/files/greeting"))))
+  (test-assert (resource? resource))
+  (test-assert (file-resource? resource))
+  ;; (test-equal "/files/greeting" (href->string (href resource)))
+  (test-equal "Hello, World!\n" (bytevector->string (content resource) (native-transcoder)))
+ )
+
diff --git a/tests/test/webdav.scm b/tests/test/webdav.scm
new file mode 100644
index 00000000..10dcf95b
--- /dev/null
+++ b/tests/test/webdav.scm
@@ -0,0 +1,354 @@
+(define-module (test webdav)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (srfi srfi-1)
+  :use-module (sxml namespaced)
+  :use-module (oop goops)
+  :use-module (calp namespaces)
+  :use-module ((hnh util) :select (sort*))
+  :use-module (datetime)
+
+  :use-module (calp webdav property)
+  :use-module (calp webdav propfind)
+  :use-module (calp webdav resource)
+  :use-module (calp webdav resource virtual)
+  )
+
+;;; NOTE these tests don't check that XML namespaces work correctly, but only as
+;;; far as not checking that the correct namespace is choosen. They should fail if
+;;; namespacing gets completely broken.
+
+;;; TODO tests for a missing resource?
+
+(define (swap p) (xcons (car p) (cdr p)))
+
+(define dt #2010-11-12T13:14:15)
+
+(define resource (make <virtual-resource>
+                   ;; local-path: '("")
+                   name: "*root"
+                   content: #vu8(1 2 3 4)
+                   creation-time: dt))
+
+(define (sort-propstats propstats)
+  (map
+   (lambda (propstat)
+     (make-propstat (propstat-status-code propstat)
+                    (sort* (propstat-property propstat)
+                           string< (compose symbol->string xml-element-tagname car))
+                    (propstat-error propstat)
+                    (propstat-response-description propstat)))
+   (sort* propstats < propstat-status-code))
+  )
+
+;; (test-equal "/" (href->string (href resource)))
+(test-equal "Basic propstat"
+    (propstat 200 (list (list (xml webdav 'getcontentlength) 4)))
+    (getcontentlength resource))
+
+
+(define (sort-symbols symbs)
+  (sort* symbs string<=? symbol->string))
+
+
+
+;;; 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"))))))
+  (test-equal "Propstat merger"
+    (list (propstat 200
+                    (list (list (xml webdav 'getcontenttype) "text/plain")
+                          (list (xml webdav 'displayname) "Displayname"))))
+    (merge-propstats ps)))
+
+
+
+(test-group "All live properties"
+ (let ((props (live-properties resource)))
+   (test-assert (list? props))
+   (for-each (lambda (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)))))
+             props)))
+
+(test-group "\"All\" live properties"
+  (let ((most (propfind-most-live-properties resource)))
+    (test-equal "Correct amount of keys" 10 (length most))
+    (for-each (lambda (propstat)
+                (test-assert "Propstat is propstat" (propstat? propstat))
+                (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)))))
+              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)))))
+
+
+
+(define ns1 (string->symbol "http://example.com/namespace"))
+
+(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)))
+
+(test-equal "Get live property"
+  (propstat 404 (list (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)))
+
+  (test-equal "Missing property"
+    (propstat 404 (list (list (xml ns1 'test2))))
+    (get-property resource (xml ns1 'test2)))
+
+  (test-equal "All dead properties"
+    (list (propstat 200 (list (list (xml ns1 'test) "Content"))))
+    (propfind-all-dead-properties resource)))
+
+(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)))
+
+  (test-equal "Existing live property (thrtough get-property)"
+    (propstat 404 `((,(xml webdav 'displayname))))
+    (get-property resource (xml webdav 'displayname)))
+  )
+
+(test-equal "propfind-selected-properties"
+  (list (propstat 404 `((,(xml webdav 'displayname)))))
+  (propfind-selected-properties resource (list (xml webdav 'displayname))))
+
+(test-group "parse-propfind"
+  (test-group "propname"
+   (let ((props (parse-propfind `(d:propfind (d:propname))
+                                `((d . ,webdav))
+                                resource)))
+
+
+     (test-group "Propfind should NEVER fail for an existing resource"
+       (test-equal 1 (length props))
+       (test-equal 200 (propstat-status-code (car props))))
+
+     (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))))
+               (propstat-property (car props)))
+
+     #;
+     (test-equal "Correct property keys"
+       (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 `(d:propfind (d:prop (d:displayname)))
+                                 `((d . ,webdav))
+                                 resource)))
+      (test-equal "Simple lookup"
+        (list (propstat 404 (list (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 '(d:propfind (d:allprop))
+                                 `((d . ,webdav))
+                                 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 'collection))
+                               )
+                         (list (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))
+                        )))
+        (sort-propstats props))))
+
+
+  (test-group "allprop with include"
+    (let ((props (parse-propfind '(d:propfind (d:allprop) (d:include))
+                                 `((d . ,webdav))
+                                 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 'collection))
+                               )
+                         (list (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))
+                         )))
+        (sort-propstats props)))
+
+
+    (let ((props (parse-propfind `(d:propfind (d:allprop)
+                                              (d:include (x:isvirtual)))
+                                 `((d . ,webdav)
+                                   (x . ,virtual-ns))
+                                 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 ns1 'test) "Content")
+                         ))
+         (propstat 404 (list (list (xml webdav 'displayname))
+                             (list (xml webdav 'getcontentlanguage))))
+         (propstat 501
+                   (list (list (xml webdav 'getetag))
+                     )))
+        (sort-propstats props)))))
+
+
+
+
+;;; Setting properties
+
+;;; We already use set-dead-property! above, but for testing get we need set,
+;;; and for testing set we need get, and get is more independent, so we start there.
+
+
+
+(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")) )))
+
+  ;; 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"))
+                                         responsedescription: "Try logging in"))))
+
+
+
+
+;;; TODO what am I doing here?
+
+(test-equal
+    (list (propstat 200
+                    `((,(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)))))
+  (let ((request namespaces
+                 (namespaced-sxml->sxml/namespaces
+                  (xml->namespaced-sxml
+                   "<?xml version=\"1.0\" encoding=\"utf-8\"?>
+<propfind xmlns=\"DAV:\">
+  <prop>
+    <getcontentlength/>
+    <getlastmodified/>
+    <executable xmlns=\"http://apache.org/dav/props/\"/>
+    <resourcetype/>
+    <checked-in/>
+    <checked-out/>
+  </prop>
+</propfind>")
+                  `((,(string->symbol "DAV:") . d)))))
+
+    (sort-propstats (parse-propfind (caddr request) (map swap namespaces) resource))))
+
+
+
+(test-group "lookup-resource"
+  (let* ((root (make <virtual-resource> name: "*root*"))
+         (a (add-collection! root "a"))
+         (b (add-collection! a "b"))
+         (c (add-resource! b "c" "~~Nothing~~")))
+    (test-eq "Lookup root"
+      root (lookup-resource root '()))
+    (test-eq "Lookup direct child"
+      a (lookup-resource root '("a")))
+    (test-eq "Lookup deep child"
+      c (lookup-resource root '("a" "b" "c")))
+    (test-assert "Lookup missing"
+      (not (lookup-resource root '("a" "d" "c"))))))
+
+
+
+
+(test-group "mkcol"
+  (let ((root (make <virtual-resource> name: "*root*")))
+    (add-collection! root "child")
+    (test-eqv "Child got added" 1 (length (children root)))))