UNFINISHED webdav server.

18 files changed, 3194 insertions, 0 deletions

diff --git a/Makefile b/Makefile
index aab3c17a..f61b2797 100644
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,6 @@
 .PHONY: all clean test \
 	check \
+	litmus \
 	static \
 	go_files \
 	lcov.info
@@ -90,3 +91,6 @@ coverage: lcov.info
 
 check:
 	tests/run-tests.scm $(if $(VERBOSE),--verbose) $(SKIP) $(LIMIT_FILES)
+
+litmus:
+	tests/litmus.scm $(path)
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 95f593a7..d5783a7f 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -12,6 +12,7 @@
 @include guile/web.texi
 @include guile/vcomponent.texi
 @include guile/sxml.texi
+@include guile/webdav.texi
 
 @node Errors and Conditions
 @section Errors and Conditions
diff --git a/doc/ref/guile/webdav.texi b/doc/ref/guile/webdav.texi
new file mode 100644
index 00000000..bf35320d
--- /dev/null
+++ b/doc/ref/guile/webdav.texi
@@ -0,0 +1,289 @@
+@node WebDAV
+@section WebDAV
+
+For a complete view of WebDAV, please see @cite{RFC4918 (HTTP
+Extensions for Web Distributed Authoring and Versioning (WebDAV))},
+but in short, and specifc for this implementation.
+
+A DAV tree consists of resources, which are analogous to files and
+directories. A resource is referenced by its href.
+
+Each resources is either a collection and have children, or have
+content. Parts of this implementation allows a collection to also have
+contents, while other does not. The standard doesn't seem to mind
+either way.
+
+Each resource also has a set of properties, modelling metadata and
+extra data about the resource.
+
+@emph{href}'s are internally represented as lists of strings, where the
+root element ``/'' is an empty list, and all other cases are mapped
+like:
+@example
+"/a/b" ⇒ '("a" "b")
+@end example
+
+@emph{resources} are GOOPS objects, which the base class
+@code{<resource>}.
+
+The user (of the library) is assumed to designate one resource
+instance as the root of the resource tree. All other resources are
+then added as (grand-)children to that resource. Each resource has a
+field @var{name}, which is the normative name used when searching by
+name in the tree@footnote{This means that one resource can't easily
+exist at multiple points in the tree}.
+
+@emph{properties} are split into live and dead properties, where live
+properties have extra handling by the server, while dead properties
+are simply carried along after the end-user put them on a resource.
+
+Live properties are handled through GOOPS methods.
+
+Dead properties are (by default) stored directly inside each resource.
+
+@node WebDAV Properties
+@subsection Properties
+
+@itemize
+@item @code{(calp webdav property)}
+@item @code{(calp webdav propfind)}
+@end itemize
+
+@subsubsection Default Live Properties
+
+@deftp {GOOPS method} creationdate
+@end deftp
+
+@deftp {GOOPS method} displayname
+@end deftp
+
+@deftp {GOOPS method} getcontentlanguage
+@end deftp
+
+@deftp {GOOPS method} getcontentlength
+@end deftp
+
+@deftp {GOOPS method} getcontenttype
+@end deftp
+
+@deftp {GOOPS method} getetag
+@end deftp
+
+@deftp {GOOPS method} getlastmodified
+@end deftp
+
+@deftp {GOOPS method} lockdiscovery
+@end deftp
+
+@deftp {GOOPS method} resourcetype
+@end deftp
+
+@deftp {GOOPS method} supportedlock
+@end deftp
+
+
+@node WebDAV Resources
+@subsection Resources
+
+@deftp {GOOPS class} <resource>
+Base type for all WebDAV resources.
+
+The base class shouldn't be directly instanciated.
+
+    @defun resource? x
+    Is the given object a <resource>, or decendant?
+    @end defun
+@end deftp
+
+@deftp {GOOPS method} name resource
+The name of a resource is the local part of a href.
+@end deftp
+
+@deftp {GOOPS method} children resource
+All direct children of a resource, as a list.
+@end deftp
+
+@deftp {GOOPS method} add-child! (parent <resource>) (child <resource>) [(overwrite? <boolean>)
+Adds a resource as a child of another resource.
+
+Currently doesn't do anything more, but will eventually call a
+bookkeeping procedure on the two resources.
+
+If @var{overwrite?} is present, then the parent will be checked for a
+child which already has that name, and take action accordingly.
+It will return one of: @code{'replaced} if a resource already existed
+with that name, but it has been replaced, @code{'collision}, if the
+old one was kept, and @code{'created} if the new resource was added
+without collisions.
+
+If @var{overwrite?} is absent then the method always returns @var{'created}.
+@end deftp
+
+@deftp {GOOPS method} add-resource! (self <resource>) (name <string>) content
+Creates a new resource with the given name, and make it a child of
+@var{self}. Setting its initial content to @var{content}.
+
+This method exists alongside @code{add-child!}, due to historical
+reasons (and that @code{add-resource!} is easier to override if custom
+setup code needs to be run.
+
+@c TODO Document throw
+@c TODO Document return
+@end deftp
+
+@deftp {GOOPS method} add-collection! (self <resource>) name
+Similar to @code{add-resource!} but the created resource is instead a collection.
+@end deftp
+
+
+@deftp {GOOPS method} is-collection? resource
+Is the given resource a collection.
+
+The base implementation simply checks if the resource has any children.
+@end deftp
+
+@deftp {GOOPS method} content resource
+@deftpx {GOOPS method} set-content! resource content
+Get and set the content of a given resource. @var{content}s type can
+be anything that the given resource type accepts. Overrides of this
+procedure should preferably save its contents properly.
+@end deftp
+
+@c 
+
+@defun get-property resource xml-tag
+@defunx get-live-property resource xml-tag
+@defunx get-dead-property resource xml-tag
+@end defun
+
+
+@defun set-property resource xml-el
+@defunx set-property! resource xml-el
+@defunx set-dead-property resource xml-el
+@defunx set-dead-property! resource xml-el
+@defunx set-live-property resource xml-el
+@defunx set-live-property! resource xml-el
+@end defun
+
+
+@defun remove-property resource xml-tag
+@defunx remove-property! resource xml-tag
+@defunx remove-dead-property resource xml-tag
+@defunx remove-dead-property! resource xml-tag
+@defunx remove-live-property resource xml-tag
+@defunx remove-live-property! resource xml-tag
+@end defun
+
+@c 
+
+@deftp {GOOPS method} copy-resource (resource <resource>) include-children? [name]
+Create a new resource which looks as similar as possible to the given
+resource. The new resource will have the same (GOOPS) class as the
+source, displayname, contentlanguage and all dead properties are
+transfered, other live properties are currently not explicitly
+transfered (but probably still transfered implicitly).
+
+The new resources name is @var{name} if given, and the name of the
+original resource otherwise.
+
+If @var{include-children?} is true then a deep copy is performed,
+otherwise no children are copied, and the resulting resource will be a
+leaf node.
+
+Content is copied verbatim.
+
+@b{NOTE} currently no helper method is called, which means that extra
+resources held by the resource object can't be copied.
+For example, FILE can't create a copy (but it also shouldn't do that
+here, but rathen when the element is ``mounted'' into the tree).
+@end deftp
+
+@c 
+
+@defun lookup-resource root-resource path
+@end defun
+
+
+@defun all-resources-under resource [prefix='()]
+Returns the given resource, and all its children in a flat list.
+
+Currently depth first, but that might change.
+The root resource is however guaranteed to be first.
+@end defun
+
+@c 
+
+@c TODO
+           make-live-property
+           live-property?
+           property-getter
+
+           property-setter-generator
+           property-remover-generator
+
+           prepare-update-properties
+
+           live-properties
+           dead-properties
+
+           webdav-properties
+
+
+@node WebDAV Resource Types
+@subsection Resource Types
+
+@subsubsection @code{(calp webdav resource base)}
+
+Implementation of @code{(calp webdav resource)}. Exists to possibly
+avoid dependency loops.
+
+@subsubsection @code{(calp webdav resource calendar)}
+@subsubsection @code{(calp webdav resource file)}
+
+Resources backed by the file system.
+
+@defun file-resource? x
+@end defun
+
+@deftp {GOOPS method} children <file-resource>
+@end deftp
+
+@deftp {GOOPS method} is-collection? <file-resource>
+@end deftp
+
+@deftp {GOOPS method} creationdate <file-resource>
+Retrived directly from the file through @command{stat -c %W $@{filename@}}.
+@end deftp
+
+@deftp {GOOPS method} content <file-resource>
+@deftpx {GOOPS method} set-content! <file-resource> data
+Directly interfaced with the file.
+
+Data can't be retrieved for collections, and will always be
+returned as a bytevector for non-collections.
+
+Data can be set either as a string or a bytevector. When a string is
+used Guile's current encoding will be used.
+@end deftp
+
+@subsubsection @code{(calp webdav resource virtual)}
+
+@node WebDAV Utilities
+@subsection Utilities
+@defun xml-element-hash-key xml-tag
+Given an xml tag object @ref{xml-tag}, return a suitable key for
+@code{hash-ref} and family.
+
+These key objects should preferably not be carried around for
+long. Prefer to keep the @emph{real} xml-tag object, and only call
+this while directly referencing the hash table.
+@end defun
+
+@defun href->string href
+HREF's are represented as lists of strings. The root resource (``/'')
+is the empty list.
+@end defun
+
+@defun string->href string
+Return a href list back into a string. A leading slash will always be added.
+@end defun
diff --git a/module/calp/namespaces.scm b/module/calp/namespaces.scm
new file mode 100644
index 00000000..09a642da
--- /dev/null
+++ b/module/calp/namespaces.scm
@@ -0,0 +1,14 @@
+(define-module (calp namespaces))
+
+;;; Commentary:
+;;; (XML) Namespaces used by different parts of the program.
+;;; Code:
+
+(define-public webdav (string->symbol "DAV:"))
+(define-public caldav (string->symbol "urn:ietf:params:xml:ns:caldav"))
+(define-public xcal   (string->symbol "urn:ietf:params:xml:ns:icalendar-2.0"))
+
+(define-public namespaces
+  `((d . ,webdav)
+    (c . ,caldav)
+    (x . ,xcal)))
diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm
new file mode 100644
index 00000000..97d5c56d
--- /dev/null
+++ b/module/calp/server/webdav.scm
@@ -0,0 +1,736 @@
+(define-module (calp server webdav)
+  :use-module ((hnh util) :select (for group -> ->> init+last catch*))
+  :use-module (ice-9 match)
+  :use-module (ice-9 regex)
+  :use-module (ice-9 format)
+  :use-module (ice-9 control)
+  :use-module (web request)
+  :use-module (web response)
+  :use-module (web uri)
+  :use-module (web server)
+  :use-module ((web http) :select (declare-method!
+                                   declare-header!))
+  :use-module (web http status-codes)
+  :use-module (datetime)
+  :use-module (sxml match)
+  :use-module (sxml namespaced)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (rnrs bytevectors)
+  :use-module (rnrs io ports)
+  :use-module (calp namespaces)
+  :use-module (calp webdav resource)
+  :use-module (calp webdav resource virtual)
+  :use-module (calp webdav resource file)
+  :use-module (calp webdav property)
+  :use-module (calp webdav propfind)
+  :use-module (calp webdav proppatch)
+  :use-module (oop goops)
+  :export (; run-run
+           run-propfind
+           run-proppatch
+           run-options
+           run-get
+           run-put
+           run-delete
+           run-mkcol
+           run-copy
+           run-move
+           run-report
+
+           root-resource
+           webdav-handler
+           ))
+
+;; (define* (my-build-response . kvs)
+;;   (define dt (datetime->string (current-datetime) "~a, ~d ~b ~Y ~H:~M:~S GMT"))
+;;   (define server (format #f "calp/~a" (@ (calp) version)))
+;;   (let ((as (kvlist->assq kvs)))
+;;     (append kvs
+;;             (list
+;;              reason-phrase: (http-status-phrase (assq-ref as code:))
+;;              headers: (append (or (assq-ref kvs headers:) '())
+;;                               (list
+;;                                server: server
+;;                                date: dt
+;;                                connection: 'keep-alive))))))
+
+(define (swap p)
+  (xcons (car p) (cdr p)))
+
+
+(define output-namespaces
+  (map (lambda (pair) (call-with-values (lambda () (car+cdr pair))
+                   xcons))
+       namespaces))
+
+;; (define (run-filter context filter-spec)
+;;   (sxml-match filter-spec
+;;               [(c:comp-filter (@ (name ,name)) . ,rest)
+;;                ;; TODO
+;;                (filter (lambda (child) (string=? name (type child)))
+;;                        (children context))]
+;;               [(c:prop-filter (@ (name ,name)))
+;;                (prop context name)
+;;                ]
+;;               [(c:prop-filter (@ (name ,name)) . ,rest)
+;;                ]
+;;               [(c:param-filter (@ (name ,name)) . ,rest)]
+;;               [(c:is-not-defined)]
+;;               [(c:text-match (@ . ,attrs) . ,data)]
+;;               [(c:time-range (@ . ,attrs))]))
+
+
+
+;; Requests can content-type be both both application/xml and text/xml, server MUST accept both (RFC 4918 8.2)
+
+;; ;; RFC 4918 8.2
+;; (catch 'parser-error
+;;   (lambda () (xml->sxml body))
+;;   (lambda (err input-port . msg)
+;;     (define err-msg
+;;       (with-output-to-string
+;;         (lambda () (for-each display msg))))
+;;     (return (build-response code: 400
+;;                             headers: ((content-type . (text/plain))))
+;;             err-msg)))
+
+;; ;; If a body is sent by the client when not expected, the server MUST repspond
+;; ;; with 415 (RFC 4918 8.4)
+
+;; PROPPATCH
+;; SHOULD support setting of arbitrary dead properties (RFC4918 9.2)
+;; Fruux supports this
+;; NOTE this means that user quotas must include dead properties
+
+
+;; A caldav server MUST support
+;; - RFC4918 (WebDAV) Class 1
+;; - RFC3744 WebDAV ACL including additional privilege defined in 6.1
+;; - HTTPS
+;; - ETags from RFC2616 (http)
+
+;; MKCALENDAR NOT required
+
+
+
+
+;; getcontentlanguage, "dead" property
+
+(declare-method! "PROPFIND" 'PROPFIND)
+(declare-method! "PROPPATCH" 'PROPPATCH)
+(declare-method! "MKCOL" 'MKCOL)
+(declare-method! "COPY" 'COPY)
+(declare-method! "MOVE" 'MOVE)
+(declare-method! "LOCK" 'LOCK)
+(declare-method! "UNLOCK" 'UNLOCK)
+(declare-method! "REPORT" 'REPORT)
+
+
+
+(define (root-element sxml)
+  (sxml-match sxml
+    [(*TOP* (*PI* . ,args) ,root) root]
+    [(*TOP* ,root) root]
+    [,root root]))
+
+
+(define root-resource (make-parameter #f))
+
+
+
+(define (parse-dav-line str)
+  (map (lambda (item)
+         (cond ((string-match "^[0-9]+$" item)
+                => (lambda (m) (number->string (match:substring m))))
+               ((string-match "^<(.*)>$" item)
+                => (lambda (m) (string->uri (match:substring m 1))))
+               (else (string->symbol item))))
+       (map string-trim-both (string-split str #\,))))
+
+(define (validate-dav-line lst)
+  (every (lambda (item)
+           (or (and (number? item) (<= 1 item 3))
+               (uri? item)
+               ;; Possibly check against list of valid tokens
+               (symbol? item)))
+         lst))
+
+(define (write-dav-line lst port)
+  (display
+   (string-join (map (lambda (item)
+                       (cond ((number? item) (number->string item))
+                             ((uri? item) (string-append "<" (uri->string item) ">"))
+                             (else (symbol->string item))))
+                     lst)
+                ", " 'infix)
+   port))
+
+(declare-header! "DAV"
+  parse-dav-line
+  validate-dav-line
+  write-dav-line)
+
+(declare-header! "Depth"
+  (lambda (str)
+    (if (string-ci=? str "Infinity")
+        'infinity
+        (string->number str)))
+  (lambda (value)
+    (memv value '(0 1 infinity)))
+  (lambda (value port)
+    (display value port)))
+
+(declare-header! "Destination"
+  string->uri
+  uri?
+  (lambda (uri port)
+    (display (uri->string uri) port)))
+
+;;; TODO
+;; (declare-header! "If")
+
+;;; TODO
+;; (declare-header! "Lock-Token")
+
+(declare-header! "Overwrite"
+  (lambda (str)
+    ;; TODO assert isn't a thing
+    ;; (assert (= 1 (string-length str)))
+    (case (string-ref str 0)
+      ((#\F) #f)
+      ((#\T) #t)
+      (else (throw 'error))))
+  boolean?
+  (lambda (b port)
+    (display (if b "T" "F")
+             port)))
+
+;;; TODO
+;; (declare-header! "Timeout")
+
+
+
+(define (run-propfind href request body)
+  (define headers (request-headers request))
+  (cond ((lookup-resource (root-resource) href)
+         => (lambda (resource)
+              (define requested-resources
+                (case (or (assoc-ref headers 'depth) 'infinity)
+                  ((0) (list (cons href resource)))
+                  ((1) (cons (cons href resource)
+                             (map (lambda (child)
+                                    (cons (append href (list (name child)))
+                                          child))
+                                  (children resource))))
+                  ((infinity) (all-resources-under resource href))))
+
+              ;; Body, if it exists, MUST have be a DAV::propfind object
+              (define-values (property-request namespaces*)
+                (cond ((string? body)
+                       (-> body
+                           xml->namespaced-sxml
+                           (namespaced-sxml->sxml/namespaces (map swap namespaces))))
+                      ((bytevector? body)
+                       (-> body
+                           (bytevector->string (make-transcoder (utf-8-codec)))
+                           xml->namespaced-sxml
+                           (namespaced-sxml->sxml/namespaces (map swap namespaces))))
+                      (else (values '(d:propfind (d:allprop))
+                                    `((d . ,webdav))))))
+
+
+              (catch 'bad-request
+                (lambda ()
+                  (values (build-response
+                           code: 207
+                           reason-phrase: (http-status-phrase 207)
+                           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
+                                               (parse-propfind (root-element property-request)
+                                                               (map swap namespaces*)
+                                                               resource)))))
+                             namespaces: output-namespaces
+                             port: port)
+                            (newline port))))
+                (lambda (err proc fmt args data)
+                  (values (build-response
+                           code: 400
+                           headers: '((content-type . (text/plain))))
+                          (lambda (port)
+                            (apply format port fmt args)))))))
+        (else (values (build-response code: 404) ""))))
+
+
+
+(define (run-proppatch href request body)
+  (cond ((lookup-resource (root-resource) href)
+         => (lambda (resource)
+              ;; Body MUST exist, and be a DAV::propertyupdate element
+              (catch 'bad-request
+                (lambda ()
+                  (values (build-response
+                           code: 207
+                           reason-phrase: (http-status-phrase 207)
+                           headers: '((content-type . (application/xml))))
+                          (lambda (port)
+                            (define-values (request namespaces*)
+                              (cond ((string? body)
+                                     (-> body
+                                         xml->namespaced-sxml
+                                         (namespaced-sxml->sxml/namespaces
+                                          (map swap namespaces))))
+                                    ((bytevector? body)
+                                     (-> body
+                                         (bytevector->string (make-transcoder (utf-8-codec)))
+                                         xml->namespaced-sxml
+                                         (namespaced-sxml->sxml/namespaces
+                                          (map swap namespaces))))
+                                    (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))))
+                             port: port))))
+                (lambda (err proc fmt args data)
+                  (values (build-response
+                           code: 400
+                           headers: '((content-type . (text/plain))))
+                          (lambda (port)
+                            (apply format port fmt args)))))))
+        (else (values (build-response code: 404) ""))))
+
+
+(define (run-options href request)
+  (values
+   (build-response code: 200
+                   headers: `((dav . (1))
+                              ;; (DAV . "calendar-access")
+                              ;; TODO collecting this set dynamically would be fancy!
+                              (allow . (GET HEAD PUT
+                                        MKCOL PROPFIND OPTIONS
+                                        DELETE
+                                        COPY
+                                        MOVE
+                                        ;; LOCK
+                                        ;; UNLOCK
+                                        ;; REPORT
+                                        ))))
+   ""))
+
+(define (run-get href request mode)
+  (cond ((lookup-resource (root-resource) href)
+         => (lambda (resource)
+              ;; "/calendar/:user/:calendar/:filename"
+              ;; headers: `((content-type ,content-type))
+              (values (build-response code: 200)
+                      (case mode
+                        ((HEAD) "")
+                        ((GET) (content resource))
+                        (else (scm-error 'misc-error "run-get"
+                                         "Unknown mode: ~s"
+                                         (list mode) #f))))))
+        (else (values (build-response code: 404) ""))))
+
+(define (run-put href request request-body)
+  (cond ((null? href)
+         (values (build-response code: 405 headers: '((content-type . (text/plain))))
+                 "Can't PUT on root resource"))
+        ((lookup-resource (root-resource) (drop-right href 1))
+         => (lambda (parent)
+              (cond ((lookup-resource parent (list (last href)))
+                     => (lambda (child)
+                          (if (is-collection? child)
+                              (values (build-response code: 405) "")
+                              (begin
+                                (set-content! child request-body)
+                                (values (build-response code: 204) "")))))
+                    (else
+                     (add-resource! parent (last href)
+                                    request-body)
+                     (values (build-response code: 201) "")))))
+        ;; No parent collection, fail per [WEBDAV] 9.7.1.
+        (else (values (build-response code: 409)))))
+
+(define (run-mkcol href request _)
+  ;; TODO href="/"
+  (if (assoc-ref (request-headers request) 'content-type)
+      (values (build-response code: 415)
+              "")
+      (let ((path name (init+last href)))
+        (cond ((lookup-resource (root-resource) path)
+               => (lambda (parent)
+                    (catch 'resource-exists
+                      (lambda ()
+                        (add-collection! parent name)
+                        (values (build-response code: 201) ""))
+                      (lambda _ (values (build-response code: 405) "")))))
+              (else
+               (values (build-response code: 409) ""))))))
+
+
+
+;;; TODO completely rewrite error handling here
+;;; TODO what happens on copy between sub-trees of different types?
+;;; Like from a <calendar-resource> tree to a <file-tree>.
+(define (run-copy source-href request)
+  (define headers (request-headers request))
+  (call/ec
+   (lambda (return)
+    (let* ((depth (or (assoc-ref headers 'depth) 'infinity))
+           (destination-uri (assoc-ref headers 'destination))
+           (dest-href (-> headers (assoc-ref 'destination)
+                          uri-path string->href))
+           (overwrite?
+            (cond ((assoc 'overwrite headers) => cdr)
+                  (else #t))))
+
+      ;; (assert (memv depth '(0 infinity)))
+      ;; (unless (string=? (listen-uri) (uri-host destination-uri))
+      ;;   (throw 'cross-domain-copy-not-supported))
+
+      (let ((dest-path dest-name (init+last dest-href)))
+        (let ((source-resource
+               (cond ((lookup-resource (root-resource) source-href) => identity)
+                     (else (return (build-response code: 404) ""))))
+              (destination-parent-resource
+               (cond ((lookup-resource (root-resource) dest-path) => identity)
+                     (else (return (build-response
+                                    code: 409
+                                    reason-phrase: (http-status-phrase 409)
+                                    headers: '((content-type . (text/plain))))
+                                   "One or more parent components of destination are missing")))))
+
+          (let ((copy (copy-resource source-resource
+                                     (case depth
+                                       ((0) #f)
+                                       ((infinity) #t)
+                                       (else (throw 'invalid-request)))
+                                     dest-name)))
+            (case (add-child! destination-parent-resource
+                              copy
+                              overwrite?)
+              ((created)
+               (values (build-response code: 201) ""))
+              ((replaced)
+               (values (build-response code: 204) ""))
+              ((collision)
+               (values (build-response code: 412) ""))))))))))
+
+
+(define (run-delete href request)
+  ;; TODO href="/"
+  (let ((path name (init+last href)))
+    (cond ((lookup-resource (root-resource) path)
+           => (lambda (parent)
+                (cond ((lookup-resource parent (list name))
+                       => (lambda (child)
+                            (delete-child! parent child)
+                            (values (build-response code: 202)
+                                    "")))
+                      (else
+                       (values (build-response code: 404) "")))))
+          (else
+           (values (build-response code: 404) "")))))
+
+
+;;; TODO read spec
+(define (run-move href request)
+  ;; TODO href="/"
+  ;; (format (current-error-port)
+  ;;         "MOVE ~s: ~s~%" href request)
+  (catch*
+   (lambda ()
+    (let ((to (-> (request-headers request)
+                  (assoc-ref 'destination)
+                  uri-path
+                  string->href))
+          (overwrite? (cond ((assoc 'overwrite request) => cdr)
+                            (else #t))))
+      (case (move-resource! (root-resource) href to overwrite?)
+        ((created)   (values (build-response code: 201) ""))
+        ((replaced)  (values (build-response code: 204) ""))
+        ((collision) (values (build-response code: 412
+                                             headers: '((content-type . (text/plain))))
+                             "Something already exists there")))
+      ))
+   (source-not-found
+    (lambda _ (values (build-response code: 404))))
+   (target-parent-not-found
+    (lambda _ (values (build-response code: 409))))))
+
+
+
+;; (define (run-report href request request-body))
+
+
+
+
+
+
+(define log-table (make-parameter #f))
+(define (init-log-table!) (log-table '()))
+(define (log-table-add! . args)
+  (for (key value) in (group args 2)
+       (log-table (acons key value (log-table)))))
+(define* (log-table-get key optional: dflt)
+  (or (assoc-ref (log-table) key)
+      dflt))
+
+(define (log-table-format . args)
+  (for-each (lambda (arg)
+              (cond ((string? arg) (display arg))
+                    ((symbol? arg) (cond ((log-table-get arg)
+                                          => display)))
+                    ((pair? arg)   (cond ((log-table-get (car arg))
+                                          => (compose display (cdr arg)))))
+                    (else #f)))
+            args))
+
+(define (emit-log!)
+  ;; (write (log-table) (current-error-port))
+  ;; (newline (current-error-port))
+  (display
+   (with-output-to-string
+     (lambda ()
+       (log-table-format (cons 'now (lambda (n) (datetime->string n "~H:~M:~S")))
+                         " " 'method " "
+                         (cons 'uri uri->string)
+                         " ")
+       (case (request-method (log-table-get 'request))
+         ((COPY MOVE) (log-table-format
+                       (cons 'headers (lambda (h) (and=> (assoc-ref h 'destination) uri->string)))
+                       " "))
+         (else ""))
+       ;; Nginx uses
+       ;; <ip> - - [<date>] "<request-line>" <request-status> <content-length> "<referer-url>" "<user-agent>"
+       (log-table-format 'response-code " "
+                         'response-phrase
+                         " "
+                         (cons 'headers (lambda (h) (assoc-ref h 'x-litmus)))
+                         "\n")
+
+       (cond ((log-table-get 'msg)
+              => (lambda (it)
+                   (display it)
+                   (newline))))))
+
+   (current-error-port))
+  )
+
+
+
+
+;; For all headers:
+;; `((server ,(format #f "calp/~a" (@ (calp) version)))
+;;   (date ,(datetime->string (current-datetime)
+;;                            "~a, ~d ~b ~Y ~H:~M:~S GMT"))
+;;   (connection keep-alive))
+
+;; Already fixed by server
+;;   (content-length ,(format #f (bytevector->length data)))
+
+
+(define (webdav-handler request request-body)
+  (define href (-> request request-uri uri-path string->href))
+  (init-log-table!)
+  (log-table-add! 'now (current-datetime)
+                  'method (request-method request)
+                  'uri (request-uri request)
+                  'headers (request-headers request)
+                  'request request)
+
+  (catch #t
+    (lambda ()
+      ;; TODO also log result of execution
+      (call-with-values
+          (lambda ()
+            (case (request-method request)
+              ((OPTIONS) (run-options href request))
+
+              ((PROPFIND)  (run-propfind  href request request-body))
+              ((PROPPATCH) (run-proppatch href request request-body))
+
+              ((GET HEAD) (run-get href request (request-method request)))
+
+              ((PUT) (run-put href request request-body))
+
+              ((DELETE) (run-delete href request))
+
+              ((MKCOL) (run-mkcol href request request-body))
+
+              ((COPY) (run-copy href request))
+              ((MOVE) (run-move href request))
+
+              ;; ((REPORT))
+
+              (else (values (build-response code: 400) ""))))
+        (lambda (head body)
+          (log-table-add!
+           'response head
+           'response-code (response-code head)
+           'response-phrase (response-reason-phrase head))
+          (emit-log!)
+          (values head body))))
+
+    (case-lambda ((err proc fmt args data)
+                  (let ((head (build-response
+                               code: 500
+                               headers: '((content-type . (text/plain)))))
+                        (errmsg (if proc
+                                    (format #f "Error in ~a: ~?~%" proc fmt args)
+                                    (format #f "~?~%" fmt args))))
+                    (log-table-add! 'response head
+                                    'response-code 500
+                                    'msg errmsg)
+                    (emit-log!)
+                    (values head errmsg)))
+                 (err
+                  (let ((errmsg (format #f "General error: ~s~%" err)))
+                    (log-table-add! 'response-code 500
+                                    'msg errmsg)
+                    (emit-log!)
+                    (values (build-response code: 500)
+                            errmsg))))))
+
+
+
+;;; TODO shouldn't this default to #f
+(root-resource
+ (let ()
+   (define root-resource (make <virtual-resource> name: "*root*"))
+
+   (define virtual-resource (make <virtual-resource>
+                              name: "virtual"
+                              content: (string->bytevector "Hello, World\n" (native-transcoder))))
+
+   (define file-tree (make <file-resource>
+                       root: "/home/hugo/tmp"
+                       name: "files"))
+
+   (mount-resource! root-resource file-tree)
+   (mount-resource! root-resource virtual-resource)
+   root-resource))
+
+
+(define (run-run)
+  (unless (root-resource)
+    (throw 'misc-error "run-run"
+           "root-resource parameter must be set before running"
+           (list) #f))
+  (run-server webdav-handler
+              'http
+              `(#:port 8102)))
+
+;; "/principals/uid/:uid"
+
+#;
+
+(define (make-make-routes)
+  (make-routes
+
+
+   ;; A file extension could be added, but
+   ;; text/calendar ⇒ .ics
+   ;; application/calendar+xml ⇒ .xcs
+   ;; application/calendar+json ⇒ UNKNOWN
+   (GET "/caldav/:user/:calendar/:filename" (user calendar filename)
+        (define requested-types
+          (cond ((assoc-ref r:headers 'accept)
+                 => (lambda (accept)
+                      (sort* accept <
+                             (lambda (type)
+                               (or (assoc-ref (cdr type) 'q)
+                                   1000)))))
+                (else '(text/calendar))))
+        (define available-types
+          '(text/calendar application/calendar+xml))
+
+        (define content-type (find (lambda (type) (memv type available-types)) requested-types))
+        (define serializer
+          (case content-type
+            ((text/calendar)             ical:serialize)
+            ((application/calendar+xml)  xcal:serialize)
+            ((application/calendar+sexp) sxcal:serialize)
+            (else (return (build-response code: 415)
+                          "Bad content type"))))
+
+        (define event
+          (copy-as-orphan
+           (get-by-uid (get-store-by-name calendar) filename)))
+
+        ;; TODO where is the event split into multiple VEVENT objects in the
+        ;; serialized form? Should be in the serializer, right?
+
+        (define component
+          (vcalendar prodid: ((@ (calp) prodid))
+                     version: "2.0"
+                     (list event)))
+
+        (values `((content-type ,content-type))
+                (call-with-output-string
+                  (lambda (p) (serializer component p)))))
+
+   (PUT "/caldav/:user/:calendar/:filename" (user calendar filename)
+        ;; Request Headers:
+        ;; If-None-Match
+        ;; Content-Type: text/calendar
+        ;;               application/calendar+xml
+
+        ;; TODO change -X-HNH to X-HNH-PRIVATE, see RFC4791 5.3.3
+
+        (define component
+          (let ((type args (car+cdr (assoc-ref r:headers 'content-type))))
+            ;; Valid args: charset component optinfo
+            ;; Invalid args: method (see RFC4791 4.1)
+            ;; Component is for redundancy?
+            ;; optinfo is implementation dependant?
+            ;; Charset already handled by HTTP server
+           (case type
+             ((text/calendar)            (ical:deserialize body))
+             ((application/calendar+xml) (xcal:deserialize body))
+             (else (return (build-response code: 415)
+                           "Can't handle that content type")))))
+
+        (unless (eq? 'VCALENDAR (type component))
+          ;; Top level object must be a VCALENDAR
+          )
+
+        ;; Must all children be VEVENT?
+        (children component)
+
+        ;; All VEVENT component must be the the same event, so they should be merged into a single event
+        (define event (handle-events component))
+
+        ;; RFC4791 5.3.2:
+        ;; > The URL for each calendar object resource is entirely arbitrary and
+        ;; > does not need to bear a specific relationship to the calendar object
+        ;; > resource's iCalendar properties or other metadata.  New calendar
+        ;; But requiring that UID and filename match makes things easier for us, at least for now
+        (unless (string=? filename (prop component 'UID))
+          (return (build-response code: 400)
+                  "UID and filename must match"))
+
+        (let ((cal (get-calendar-by-name global-event-object calendar)))
+          ;; (add-and-save-event global-event-object cal component)
+
+          (reparent! cal event)
+          (queue-write (get-store-for-calendar cal) event)
+
+          )
+
+        )
+   ))
diff --git a/module/calp/webdav/property.scm b/module/calp/webdav/property.scm
new file mode 100644
index 00000000..092d270a
--- /dev/null
+++ b/module/calp/webdav/property.scm
@@ -0,0 +1,91 @@
+(define-module (calp webdav property)
+  :use-module (sxml namespaced)
+  :use-module (web http status-codes)
+  :use-module ((srfi srfi-1) :select (concatenate find))
+  :use-module (srfi srfi-9)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (hnh util)
+  :use-module (calp namespaces)
+  :export (make-propstat
+           propstat?
+           propstat-status-code
+           propstat-property
+           propstat-error
+           propstat-response-description
+
+           propstat
+
+           merge-propstats
+           propstat-200?
+           ;; propstat->sxml
+           propstat->namespaced-sxml
+           ))
+
+;;; Commentary:
+;;; Code:
+
+
+;; Maps directly to [WEBDAV]'s propstat objects. This is just a simpler interface in the code.
+
+(define-record-type <propstat>
+  (make-propstat status prop error responsedescription)
+  propstat?
+  ;; An http status code indicating if this property is present
+  (status propstat-status-code)
+  ;; A list of namespaced sxml elements, such that they could all be
+  ;; directly inserted as the children of <DAV::prop/>
+  ;; @example
+  ;; `((,(xml ns tag) "Content"))
+  ;; @end example
+  (prop propstat-property)
+
+  ;; See [WEBCAL] propstat XML element
+  (error propstat-error)
+  (responsedescription propstat-response-description))
+
+(define* (propstat code prop key: error responsedescription)
+  (make-propstat code prop error responsedescription))
+
+;; Query a given dead property from the given resource
+;; property should be a xml-element item
+;; (define (propfind-selected-property resource property)
+;;   (cond ((get-dead-property resource property)
+;;          => (lambda (it) (propstat 200 (list it))))
+;;         (else (propstat 404 (list (list property))))))
+;; Takes a list of <propstat> items, finds all where status, error, and
+;; responsedescription are all equal, and merges the prop tags of all those.
+;; Returns a new list of <propstat> items
+(define (merge-propstats propstats)
+  (map (lambda (group)
+         (define-values (code error desc) (unlist (car group)))
+         (make-propstat code
+                        (concatenate
+                         (map propstat-property (cdr group)))
+                        error desc))
+       (group-by (lambda (propstat)
+                   (list (propstat-status-code propstat)
+                         (propstat-error propstat )
+                         (propstat-response-description propstat)))
+                 propstats)))
+
+(define (propstat-200? prop)
+  (= 200 (propstat-status-code prop)))
+
+
+;; (define (propstat->sxml propstat)
+;;   `(d:propstat (d:prop ,(propstat-property propstat))
+;;                (d:status ,(http-status-line (propstat-status-code propstat)))
+;;                ,@(awhen (propstat-error propstat)
+;;                         `((d:error ,it)))
+;;                ,@(awhen (propstat-response-description propstat)
+;;                         `((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)))))
diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm
new file mode 100644
index 00000000..e6becafd
--- /dev/null
+++ b/module/calp/webdav/propfind.scm
@@ -0,0 +1,93 @@
+(define-module (calp webdav propfind)
+  :use-module (calp webdav property)
+  :use-module (calp webdav resource)
+  :use-module (sxml match)
+  :use-module (sxml namespaced)
+  :export (propfind-selected-properties
+           propfind-all-live-properties
+           propfind-most-live-properties
+           propfind-all-dead-properties
+
+           parse-propfind
+           ))
+
+;;; Commentary:
+;;; Procedures for the WebDav PROPFIND method
+;;; Code:
+
+;; Properties should be a list of xml-tag-elements
+;; return a list of propstat elements
+;; work for both dead and alive objects
+(define (propfind-selected-properties resource properties)
+  (map (lambda (el) (get-property resource el))
+       properties))
+
+
+;; (define-method (supported-properties (self <resource>))
+;;   (map (lambda (v) (cons webdav v))
+;;        `()))
+
+;; Returns a list of <propstat> objects.
+(define (propfind-all-live-properties resource)
+  (map (lambda (p) ((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)
+  (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)
+  (map (lambda (v) (propstat 200 (list v)))
+       (dead-properties resource)))
+
+
+
+
+
+
+;; Takes a propfind xml element (tree), and a webdav resource object.
+;; Returns a list of <propstat> objects.
+(define (parse-propfind sxml namespaces resource)
+  (merge-propstats
+   ;; TODO Allow *TOP* and *PI*?
+   (sxml-match sxml
+     ((d:propfind (d:propname))
+      ;; Return the list of available properties
+      (list (propstat
+             200
+             ;; car to get tagname, list to construct a valid xml element
+             (map (compose list car)
+                  (append
+                   (dead-properties resource)
+                   (live-properties resource))))))
+
+     ((d:propfind (d:allprop))
+      ;; Return "all" properties
+      (append
+       (propfind-most-live-properties resource)
+       (propfind-all-dead-properties resource)))
+
+     ((d:propfind (d:allprop) (d:include ,properties ...))
+      ;; Return "all" properties + those noted by <include/>
+      (append
+       (propfind-most-live-properties resource)
+       (propfind-all-dead-properties resource)
+       (propfind-selected-properties
+        resource
+        (map (lambda (prop) (car (sxml->namespaced-sxml prop namespaces)))
+             properties))))
+
+     ((d:propfind (d:prop ,properties ...))
+      ;; Return the properties listed
+      (propfind-selected-properties
+       resource
+       (map (lambda (prop) (car (sxml->namespaced-sxml prop namespaces)))
+            properties)))
+
+     (,default (scm-error 'bad-request "parse-propfind"
+                      "Invalid search query ~s" (list default) (list default)))
+     )))
diff --git a/module/calp/webdav/proppatch.scm b/module/calp/webdav/proppatch.scm
new file mode 100644
index 00000000..db7f5f95
--- /dev/null
+++ b/module/calp/webdav/proppatch.scm
@@ -0,0 +1,67 @@
+(define-module (calp webdav proppatch)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (calp webdav property)
+  :use-module (calp webdav resource)
+  :use-module (sxml match)
+  :use-module (sxml namespaced)
+  :use-module ((hnh util) :select (for))
+  :export (parse-propertyupdate)
+  )
+
+
+(define (parse-propertyupdate body namespaces resource)
+  (merge-propstats
+   (sxml-match body
+     [(d:propertyupdate . ,changes)
+      (define continuations
+        (concatenate
+         (for change in changes
+              (sxml-match change
+                [(d:remove (d:prop . ,properties))
+                 (map (lambda (prop) (cons prop
+                                      (remove-property
+                                       resource
+                                       (car
+                                        (sxml->namespaced-sxml prop namespaces)))))
+                      properties)]
+
+                ;; TODO handle xmllang correctly
+                [(d:set (d:prop . ,properties))
+                 (map (lambda (prop) (cons prop
+                                      (set-property resource
+                                                    (sxml->namespaced-sxml prop namespaces))))
+                      properties)]
+
+                [,else (scm-error 'bad-request ""
+                                  "Invalid propertyupdate: ~s"
+                                  (list body)
+                                  (list body))]))))
+
+      ;; (format (current-error-port) "~s~%" continuations)
+      (let loop ((continuations continuations))
+        (if (null? continuations)
+            '()
+            (let ((tag proc (car+cdr (car continuations))))
+              (set! tag (sxml->namespaced-sxml tag namespaces))
+              ;; (format (current-error-port) "tag: ~s~%" tag)
+              (catch #t (lambda ()
+                          ;; This is expected to throw quite often
+                          (proc)
+                          (cons (propstat 200 (list tag))
+                                (loop (cdr continuations))))
+                (lambda err
+                  (cons (propstat 409 (list tag))
+                        (mark-remaining-as-failed-dependency (cdr continuations))))))))]
+
+     [,else (scm-error 'bad-request ""
+                       "Invalid root element: ~s"
+                       (list else)
+                       (list else))])))
+
+
+(define (mark-remaining-as-failed-dependency pairs)
+  (map (lambda (item)
+         (propstat 424 (list (car item))))
+       pairs))
diff --git a/module/calp/webdav/resource.scm b/module/calp/webdav/resource.scm
new file mode 100644
index 00000000..47c5aded
--- /dev/null
+++ b/module/calp/webdav/resource.scm
@@ -0,0 +1,15 @@
+(define-module (calp webdav resource)
+  :use-module (srfi srfi-88)
+  :use-module (oop goops)
+  :use-module (calp webdav resource base)
+  :export (mount-resource!))
+
+(define cm (module-public-interface (current-module)))
+(module-use! cm (resolve-interface '(calp webdav resource base)))
+
+;;; TODO mount-resource! vs add-child!
+;;; Would a good idea be that add-resource! adds directly, and should
+;;; be considered internal, while mount-resource! also runs post-add
+;;; hooks, and could thereby be exported
+(define-method (mount-resource! (this <resource>) (child <resource>))
+  (add-child! this child))
diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm
new file mode 100644
index 00000000..0b1d4ace
--- /dev/null
+++ b/module/calp/webdav/resource/base.scm
@@ -0,0 +1,572 @@
+(define-module (calp webdav resource base)
+  :use-module ((srfi srfi-1) :select (find remove last append-map drop-while))
+  :use-module (srfi srfi-9)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (oop goops)
+  :use-module (sxml namespaced)
+  :use-module (calp webdav property)
+  :use-module (calp namespaces)
+  :use-module ((hnh util) :select (unless))
+  :use-module (rnrs bytevectors)
+  :use-module (hnh util)
+  :use-module (hnh util env)
+  :use-module (datetime)
+  :export (<resource>
+           ;; href
+           href->string
+           string->href
+           ;; local-path
+           name
+           dead-properties
+           ;; resource-children
+           resource?
+           children
+           xml-element-hash-key
+
+
+
+           get-live-property
+           get-dead-property
+           get-property
+
+           set-dead-property
+           set-dead-property!
+           set-live-property
+           set-live-property!
+           set-property
+           set-property!
+
+           remove-dead-property
+           remove-dead-property!
+           remove-live-property
+           remove-live-property!
+           remove-property
+           remove-property!
+
+
+
+
+           live-properties
+           add-child!
+           add-resource!
+           add-collection!
+           is-collection?
+
+           content
+           set-content!
+
+           copy-resource
+           cleanup-resource
+           delete-child!
+           move-resource!
+           setup-new-resource!
+           ;; prepare-for-add!
+
+           creationdate
+           displayname
+           getcontentlanguage
+           getcontentlength
+           getcontenttype
+           getetag
+           getlastmodified
+           lockdiscovery
+           resourcetype
+           supportedlock
+
+           webdav-properties
+
+           ;; absolute-path
+           ;; find-resource
+           lookup-resource
+           all-resources-under
+
+           ;; dereference
+
+           make-live-property
+           live-property?
+           property-getter
+           property-setter-generator
+           property-remover-generator
+
+           prepare-update-properties
+
+           ))
+
+
+(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* (make-live-property getter setter-generator optional: remover-generator)
+  (make-live-property% getter setter-generator remover-generator))
+
+
+
+;; Collections are also resources, this is non-collection resources
+(define-class <resource> ()
+  ;; (href init-keyword: href: getter: href init-value: #f)
+  ;; (local-path init-keyword: local-path: getter: local-path)
+
+  ;; name is a part of its search path.
+  ;; For example: the component located at /a/b
+  ;; would have name="a", its parent name="b", and the root element
+  ;; would have an unspecified name (probably the empty string, or "*root*")
+  (name init-keyword: name: getter: name)
+
+  (dead-properties
+   ;; Map from (namespace . tagname) pairs to namespaced xml element
+   init-form: (make-hash-table)
+   getter: dead-properties%)
+
+  ;; Attributes on data
+  (displayname accessor: displayname* init-value: #f)
+  (contentlanguage accessor: contentlanguage init-value: #f)
+
+  ;; Direct children, used by @code{children} if not overwritten by child
+  (resource-children init-value: '()
+                     accessor: resource-children)
+
+  ;; Table containing href -> resource mappings, saves us from recursivly searching children each time.
+  (resource-cache init-value: (make-hash-table 0)
+                  getter: resource-cache))
+
+(define (resource? x)
+  (is-a? x <resource>))
+
+
+(define (href->string href)
+  (if (null? href)
+      "/" (string-join href "/" 'prefix)))
+
+(define (string->href s)
+  (remove string-null?
+          (string-split s #\/)))
+
+(define-method (children (self <resource>))
+  (resource-children self))
+
+;;; TODO merge content and set-content! into an accessor?
+(define-method (content (self <resource>))
+  (throw 'misc-error "content<resource>"
+         "Base <resource> doesn't implement (getting) content, please override this method"
+         '() #f))
+
+(define-method (set-content! (self <resource>) content)
+  (throw 'msic-error "set-content!<resource>"
+         "Base <resource> doesn't implement (setting) content, please override this method"
+         '() #f))
+
+(define-method (content-length (self <resource>))
+  (if (is-collection? self)
+      0
+      (let ((c (content self)))
+        (cond ((bytevector? c) (bytevector-length c))
+              ((string? c) (string-length c))
+              (else -1)))))
+
+(define-method (write (self <resource>) port)
+  (catch #t
+    (lambda ()
+      (display ; Make output atomic
+       (call-with-output-string
+         (lambda (port)
+           ;; (define o (dereference self))
+           (format port "#<~a name=~s"
+                   (class-name (class-of self))
+                   (name self))
+           (cond ((displayname self)
+                  propstat-200?
+                  (lambda (name) (format port ", displayname=~s" name))))
+           (format port ">")))
+       port))
+    (lambda _
+      (format port "#<~a>" (class-name (class-of self))))))
+
+
+;;; TODO should add-resource! be kept? It would probably be better to merge it
+;;; with add-child!
+
+
+
+;; Possibly change this to a fixed procedure
+(define-method (add-resource! (self <resource>)
+                              (new-name <string>)
+                              content)
+  (if (lookup-resource self (list new-name))
+      (throw 'resource-exists)
+      (let ((resource (make (class-of self) name: new-name)))
+        (setup-new-resource! resource self)
+        (add-child! self resource)
+        (set-content! resource content)
+        resource)))
+
+;; Possibly change this to a fixed procedure,
+;; adding a setup method instead
+(define-method (add-collection! (self <resource>) new-name)
+  (if (lookup-resource self (list new-name))
+      (throw 'resource-exists)
+      (let ((resource (make (class-of self) name: new-name)))
+        (add-child! self resource)
+        resource)))
+
+(define-method (copy-resource (self <resource>) include-children?)
+  (copy-resource self include-children? #f))
+
+(define-method (copy-resource (self <resource>) include-children? new-name)
+  (let ((resource (make (class-of self) name: (or new-name (name self)))))
+    (for-each (lambda (tag) (set-dead-property! resource tag))
+              (dead-properties self))
+    (set! (displayname* resource)    (displayname* self)
+          (contentlanguage resource) (contentlanguage self))
+    (set-content! resource (content self))
+    (when include-children?
+      (for-each (lambda (c) (add-child! resource c))
+                (map (lambda (c) (copy-resource c #t))
+                     (children self))))
+    ;; resource-cache should never be copied
+    resource))
+
+(define (xml-element-hash-key tag)
+  "Returns a value suitable as a key to hash-ref (and family)"
+  (cons (xml-element-namespace tag)
+        (xml-element-tagname tag)))
+
+;; Only tagname and namespaces are checked on the <xml-element> for the {get,set}-property
+
+
+;;; 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)))
+
+;;; TODO should {get,set}{,-{dead,live}}-property really be methods?
+;;; - Live properties are defined by lookup-live-property, which isn't a
+;;;   method, which in turn calls live-properties, which MUST be a method.
+;;; - Dead properties may have a reason. For example, file resources might
+;;;   want to store them directly in xattrs, ignoring its built in hash-table.
+;;; - The combined should always just dispatch to either one
+
+(define-method (get-live-property (resource <resource>) xml-el)
+  (cond ((lookup-live-property resource xml-el)
+         => (lambda (pair) ((property-getter pair) resource)))
+        (else (propstat 404 (list (list xml-el))))))
+
+(define-method (get-dead-property (resource <resource>) xml-el)
+  (cond ((hash-ref (dead-properties% resource)
+                   (xml-element-hash-key xml-el))
+         => (lambda (it) (propstat 200 (list it))))
+        (else (propstat 404 (list (list xml-el))))))
+
+;;; Return a list xml tags (including containing list)
+(define-method (dead-properties (resource <resource>))
+  (hash-map->list (lambda (_ v) v)
+                  (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))
+  (lambda ()
+    (hash-set! (dead-properties% resource)
+               (xml-element-hash-key (car value))
+               value)))
+
+(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))
+  (cond ((lookup-live-property resource (car value))
+         => (lambda (prop) (apply (property-setter-generator prop)
+                             resource (cdr value))))
+        (else #f)))
+
+(define (set-dead-property! resource value)
+  ((set-dead-property resource value)))
+
+(define (set-live-property! resource value)
+  ((set-live-property resource value)))
+
+(define (set-property resource value)
+  (or (set-live-property resource value)
+      (set-dead-property resource value)))
+
+(define (set-property! resource value)
+  ((set-property resource value)))
+
+;;; The remove-* procedures still take "correct" namespaced sxml (so an
+;;; xml-element object inside a list). These extra lists are a bit of a waste,
+;;; 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))
+  (lambda ()
+    (hash-remove! (dead-properties% resource)
+                  (xml-element-hash-key xml-tag))))
+
+(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))
+
+  (cond ((lookup-live-property resource xml-tag)
+         => (lambda (prop)
+              (cond ((property-remover-generator prop)
+                     => (lambda (f) (f resource)))
+                    (else (throw 'irremovable-live-property)))))
+        (else #f)))
+
+(define (remove-dead-property! resource xml-tag)
+ ((remove-dead-property resource xml-tag)))
+
+(define (remove-live-property! resource xml-tag)
+  ((remove-live-property resource xml-tag)))
+
+(define-method (remove-property (resource <resource>) xml-tag)
+  (or (remove-live-property resource xml-tag)
+      (remove-dead-property resource xml-tag)))
+
+(define (remove-property! resource xml-tag)
+  ((remove-property resource xml-tag)))
+
+
+
+;; xml-tag should be just the tag element, without a surounding list
+(define-method (get-property (resource <resource>) xml-tag)
+  (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)
+;; to generic procedures returning that value.
+;; SHOULD be extended by children, which append their result to this result
+;; @example
+;; (define-method (live-properties (self <specific-resource>)
+;;   (append (next-method)
+;;           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)))
+       webdav-properties))
+
+(define-method (setup-new-resource! (this <resource>) (parent <resource>))
+  'noop)
+
+(define-method (add-child! (this <resource>) (child <resource>))
+  ;; TODO this should call a method on child, allowing it to be updated
+  ;; with aditional context
+  ;; (prepare-for-add! child this)
+  (set! (resource-children this)
+    (cons child (resource-children this)))
+  'created)
+
+(define-method (add-child! (this <resource>) (child <resource>) (overwrite? <boolean>))
+  (let ((existing (lookup-resource this (list (name child)))))
+    (cond ((and overwrite? existing)
+           (set! (resource-children this)
+             ;; TODO properly remove the old node, similar to mov DELETE
+             ;; will do it (calling cleanup, and so on).
+             (cons child (delete existing (children this))))
+           'replaced)
+          (existing 'collision)
+          (else
+           (add-child! this child)
+           'created))))
+
+;; Free any aditional system resources held by this object.
+;; For example, file resources will remove the underlying file here.
+(define-method (cleanup-resource (this <resource>))
+  'noop)
+
+(define-method (delete-child! (this <resource>) (child <resource>))
+  (set! (resource-children this)
+    (delq1! child (children this)))
+  (for-each (lambda (grandchild)
+              (delete-child! child grandchild))
+            (children child))
+  (cleanup-resource child))
+
+
+(define-method (move-resource! (root <resource>)
+                               from to
+                               (overwrite? <boolean>))
+  (let* ((dest-path dest-name (init+last to))
+         (from-path from-name (init+last from))
+         (dest-parent (or (lookup-resource root dest-path)
+                          (throw 'target-parent-not-found)))
+         (from-parent (or (lookup-resource root from-path)
+                          (throw 'source-not-found)))
+         (source (or (lookup-resource from-parent (list from-name))
+                     (throw 'source-not-found))))
+    (if (and (is-collection? source)
+             (not overwrite?))
+        'collision
+        ;; run move by running a  copy followed by a delete.
+        ;; [RFC4918] 9.9.3 specifies that the server MUST run a DELETE
+        ;; on the target if overwrite is true, but I actually don't
+        ;; see the difference between that and a propper move...
+        (let ((status (add-child! dest-parent (copy-resource source #t dest-name)
+                                  overwrite?)))
+          (case status
+            ((created replaced)
+             (delete-child! from-parent source)
+             status)
+            (else status))))))
+
+
+
+
+
+;;; TODO rename to simply @code{collection?}
+(define-method (is-collection? (self <resource>))
+  (not (null? (resource-children self))))
+
+
+
+
+(define-method (creationdate (self <resource>))
+  (propstat 501 `((,(xml webdav 'creationdate)))))
+
+(define-method (set-creationdate! (self <resource>) _)
+  (throw 'protected-resource "creationdate"))
+
+(define-method (displayname (self <resource>))
+  (cond ((displayname* self)
+         => (lambda (name)
+              (propstat 200 `((,(xml webdav 'displayname)
+                               ,name)))))
+        (else
+         (propstat 404 `((,(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)))))))
+
+(define-method (set-getcontentlanguage! (self <resource>) value)
+  (lambda () (set! (contentlanguage self) value)))
+
+(define-method (getcontentlength (self <resource>))
+  (propstat 501 `((,(xml webdav 'getcontentlength)))))
+
+(define-method (getcontentlength (self <resource>))
+  (propstat 200
+            (list
+             (list (xml webdav 'getcontentlength)
+                   (content-length self)))))
+
+(define-method (set-getcontentlength! (self <resource>) _)
+  (throw 'protected-resource "getcontentlength"))
+
+(define-method (getcontenttype (self <resource>))
+  (propstat 501 `((,(xml webdav 'getcontenttype)))))
+
+(define-method (set-getcontenttype! (self <resource>) _)
+  (throw 'protected-resource "getcontenttype"))
+
+(define-method (getetag (self <resource>))
+  ;; TODO
+  (propstat 501 `((,(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")))))))
+
+(define-method (set-getlastmodified! (self <resource>) _)
+  (throw 'protected-resource "getlastmodified"))
+
+(define-method (lockdiscovery (self <resource>))
+  (propstat 200 `((,(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))))))))
+
+(define-method (set-resourcetype! (self <resource>) _)
+  (throw 'protected-resource "resourcetype"))
+
+(define-method (supportedlock (self <resource>))
+  (propstat 200 `((,(xml webdav 'supportedlock) ()))))
+
+(define-method (set-supportedlock! (self <resource>) _)
+  (throw 'protected-resource "supportedlock"))
+
+(define webdav-properties
+  `((creationdate       . ,(make-live-property creationdate set-creationdate!))
+    (displayname        . ,(make-live-property displayname set-displayname!))
+    (getcontentlanguage . ,(make-live-property getcontentlanguage set-getcontentlanguage!))
+    (getcontentlength   . ,(make-live-property getcontentlength set-getcontentlength!))
+    (getcontenttype     . ,(make-live-property getcontenttype set-getcontenttype!))
+    (getetag            . ,(make-live-property getetag set-getetag!))
+    (getlastmodified    . ,(make-live-property getlastmodified set-getlastmodified!))
+    (lockdiscovery      . ,(make-live-property lockdiscovery set-lockdiscovery!))
+    (resourcetype       . ,(make-live-property resourcetype set-resourcetype!))
+    (supportedlock      . ,(make-live-property supportedlock set-supportedlock!))))
+
+
+
+;;; TODO remove! This is a remnant of the old mount system
+;; (define-method (dereference (self <resource>))
+;;   self)
+
+(define (find-resource resource path)
+  ;; Resource should be a <resource> (or something descended from it)
+  ;; path should be a list of strings
+  (cond ((null? path) resource)
+        ((string-null? (car path))
+         ;; resource
+         (find-resource resource (cdr path)))
+        ((find (lambda (r) (string=? (car path) (name r)))
+               (children resource))
+         => (lambda (r) (find-resource r (cdr path))))
+        (else #f)))
+
+;; Lookup up a given resource first in the cache,
+;; Then in the tree
+;; and finaly fails and returns #f
+(define (lookup-resource root-resource path)
+  (find-resource root-resource path)
+  #;
+  (or (hash-ref (resource-cache root-resource) path)
+      (and=> (find-resource root-resource path)
+             (lambda (resource)
+               (hash-set! (resource-cache root-resource) path resource)
+               resource))))
+
+(define* (all-resources-under* resource optional: (prefix '()))
+  (define s (append prefix (list (name resource))))
+  (cons (cons s resource)
+        (append-map (lambda (c) (all-resources-under* c s))
+                    (children resource))))
+
+;; Returns a flat list of this resource, and all its decendants
+(define* (all-resources-under resource optional: (prefix '()))
+  (cons (cons prefix resource)
+        (append-map (lambda (c) (all-resources-under* c prefix))
+                    (children resource))))
diff --git a/module/calp/webdav/resource/calendar.scm b/module/calp/webdav/resource/calendar.scm
new file mode 100644
index 00000000..6c20df31
--- /dev/null
+++ b/module/calp/webdav/resource/calendar.scm
@@ -0,0 +1,129 @@
+(define-module (calp webdav resource calendar)
+  :use-module (srfi srfi-88)
+  :use-module (hnh util)
+  :use-module (oop goops)
+  :use-module (vcomponent)
+  :use-module (datetime)
+  :use-module (sxml namespaced)
+  :use-module (calp webdav resource)
+  :use-module (calp webdav property)
+  :use-module (calp namespaces)
+  :use-module (ice-9 hash-table)
+  :use-module ((vcomponent formats ical) :prefix #{ics:}#)
+  :export (<calendar-resource>
+           calendar-resource?
+           content
+           caldav-properties)
+  )
+
+;;; Resoruces containing calendar components
+(define-class <calendar-resoruce> (<resource>)
+  (description init-value: #f
+               accessor: description)
+  (content init-value: (make-vcomponent 'VIRTUAL)
+           accessor: content))
+
+(define (calendar-resource? x)
+  (is-a? x <calendar-resource>))
+
+(define-method (live-properties (self <calendar-resource>))
+  (append (next-method)
+          (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair)))
+               caldav-properties)))
+
+(define-method (creationdate (self <calendar-resource>))
+  (propstat 200
+            `((,(xml webdav 'creationdate)
+               (-> (content self)
+                   (prop 'CREATED)
+                   ;; TODO timezone
+                   (datetime->string "~Y-~m-~dT~H:~M:~SZ"))))))
+
+(define-method (displayname (self <calendar-resource>))
+  (propstat 200
+            `((,(xml webdav 'displayname)
+               ,(prop (content self) 'displayname)))))
+
+
+(define-method (getcontentlength (self <calendar-resoruce>))
+  ;; TODO which representation should be choosen to calculate length?
+  (propstat 501 `((,(xml webdav 'getcontentlength)))))
+
+(define-method (getcontenttyype (self <calendar-resource>))
+  ;; TODO different representations
+  (propstat 200 `((,(xml webdav 'getcontentlength)
+                   "text/calendar"))))
+
+
+(define-method (getlastmodified (self <calendar-resource>))
+  (propstat 200
+            `((,(xml webdav 'getlastmodified)
+               (string->datetime (prop (content self) 'LAST-MODIFIED)
+                                 "~Y~m~dT~H~M~S")))))
+
+
+(define-method (resourcetype (self <calendar-resource>))
+  (propstat 200
+   `((,(xml webdav 'resourcetype)
+      (,(xml caldav 'calendar))))))
+
+;;; CALDAV Properties
+
+;; NOT in allprop
+(define-method (calendar-description (self <calendar-resource>))
+  (cond ((description self)
+         => (lambda (it)
+              (propstat 200
+                        (list (list (xml caldav 'calendar-description (alist->hashq-table '((xml:lang . "en"))))
+                                    it)))))
+        (else
+         (propstat 404 (list (list (xml caldav 'calendar-description)))))))
+
+;; NOT in allprop
+(define-method (calendar-timezone (self <calendar-resource>))
+  (propstat 200
+            (list
+             (list (xml caldav 'calendar-description)
+                   ;; TODO serialize, base-timezone
+                   (ics:serialize (base-timezone (content self)))))))
+
+;; NOT in allprop
+(define-method (supported-calendar-component-set (self <calendar-resource>))
+  (propstat 200
+            `((,(xml caldav 'supported-calendar-component-set)
+               (,(xml caldav 'comp
+                      (alist->hashq-table '((name . "VEVENT")))))))))
+
+(define-method (supported-calendar-data (self <calendar-resource>))
+  (propstat 200
+   (list
+    (list
+     (xml caldav 'supported-calendar-data)
+     (map (lambda (content-type)
+            (list (xml caldav 'calendar-data
+                       (alist->hashq-table
+                        '((content-type . ,content-type)
+                          (version . "2.0"))))))
+          '("text/calendar" "application/calendar+xml"))))))
+
+;; (define-method (max-resource-size (self <calendar-resource>))
+;;   )
+
+;; (define-method (min-date-time ))
+;; (define-method (max-date-time ))
+;; (define-method (max-instances ))
+;; (define-method (max-attendees-per-instance ))
+
+(define caldav-properties
+  `((calendar-description . ,calendar-description)
+    (calendar-timezone . ,calendar-timezone)
+    (supported-calendar-component-set . ,supported-calendar-component-set)
+    (supported-calendar-data . ,supported-calendar-data)
+    ;; (max-resource-size . ,max-resource-size)
+    ;; (min-date-time . ,min-date-time)
+    ;; (max-date-time . ,max-date-time)
+    ;; (max-instances . ,max-instances)
+    ;; (max-attendees-per-instance . ,max-attendees-per-instance)
+    ))
+
+
diff --git a/module/calp/webdav/resource/file.scm b/module/calp/webdav/resource/file.scm
new file mode 100644
index 00000000..58e71e2c
--- /dev/null
+++ b/module/calp/webdav/resource/file.scm
@@ -0,0 +1,188 @@
+(define-module (calp webdav resource file)
+  :use-module (srfi srfi-1)
+  :use-module (oop goops)
+  :use-module (hnh util)
+  :use-module (hnh util env)
+  :use-module (hnh util path)
+  :use-module (datetime)
+  :use-module (ice-9 popen)
+  :use-module (ice-9 rdelim)
+  :use-module (ice-9 ftw)
+  :use-module (sxml namespaced)
+  :use-module (calp webdav resource)
+  :use-module (calp webdav property)
+  :use-module (calp namespaces)
+  :use-module (rnrs io ports)
+  :use-module (rnrs bytevectors)
+  :export (<file-resource> file-resource? root ; path
+                           ))
+
+;;; Resources backed by the filesystem
+(define-class <file-resource> (<resource>)
+  ;; Directory to act as root for this file tree.
+  ;; Should be inherited by all children
+
+  ;; DO NOT export the setters. These fields needs to be carefully managed to
+  ;; ensure that they stay consistant with the @var{name} trail.
+  (root getter: root setter: set-root! init-value: "/" init-keyword: root:)
+  (path getter: path setter: set-path! init-value: "/" init-keyword: path:))
+
+(define (file-resource? x)
+  (is-a? x <file-resource>))
+
+;; TODO this is global, so most certanly leaks info between different
+;; <file-resource> trees.
+(define *realized-resource* (make-hash-table))
+
+(define (file-resource-for-path root path)
+  (or (hash-ref *realized-resource* path)
+      (let ((resource (make <file-resource>
+                        ;; href:
+                        root: root
+                        ; local-path: path
+                        name: (basename path)
+                        path: path
+                        )))
+        (hash-set! *realized-resource* path resource)
+        resource)))
+
+(define (filepath self)
+  (path-append (root self)
+               (path self)))
+
+(define-method (children (self <file-resource>))
+  ;; (format (current-error-port) "root=~s, path=~s~%"
+  ;;         (root self)
+  ;;         (local-path self))
+  (when (is-collection? self)
+    (map (lambda (p) (file-resource-for-path (root self)
+                                        (path-append (path self)
+                                                     p)))
+         (remove (lambda (p) (member p '("." "..")))
+                 (scandir (filepath self))))))
+
+(define-method (is-collection? (self <file-resource>))
+  (eq? 'directory (stat:type (stat (filepath self)))))
+
+(define (file-creation-date path)
+  (let ((pipe (open-pipe* OPEN_READ "stat" "-c" "%W" path)))
+    (begin1 (unix-time->datetime (read pipe))
+            (close-pipe pipe))))
+
+(define (mimetype path)
+  (let ((pipe (open-pipe* OPEN_READ "file" "--brief" "--mime-type"
+                          path)))
+    (begin1 (read-line pipe)
+            (close-pipe pipe))))
+
+(define-method (creationdate (self <file-resource>))
+  (propstat 200
+            `((,(xml webdav 'creationdate)
+               ,(with-locale1
+                 LC_TIME "C"
+                 (lambda ()
+                  (-> (file-creation-date (filepath self))
+                      (datetime->string "~Y-~m-~dT~H:~M:~S~Z"))))))))
+
+(define-method (content (self <file-resource>))
+  (if (is-collection? self)
+      #f
+      (call-with-input-file (filepath self)
+        get-bytevector-all binary: #t)))
+
+(define-method (set-content! (self <file-resource>) data)
+  (cond ((bytevector? data)
+         (call-with-output-file (filepath self)
+           (lambda (port) (put-bytevector port data))))
+        ((string? data)
+         (call-with-output-file (filepath self)
+           (lambda (port) (put-string port data))))
+        (else (scm-error 'misc-error "set-content!<file-resource>"
+                         "Content must be bytevector or string: ~s"
+                         (list data) #f))))
+
+
+;; This is currently ONLY called from add-resource! which creates a
+;; child from the type of the parent.
+(define-method (setup-new-resource! (self <file-resource>)
+                                    (parent <file-resource>))
+  (set-root! self (root parent))
+  (set-path! self (path-append (path parent) (name self))))
+
+
+(define-method (add-collection! (self <file-resource>) new-name)
+  (let ((resource (next-method)))
+    (set-root! resource (root self))
+    (set-path! resource (path-append (path self) new-name))
+    (mkdir (path-append (root resource) (path resource)))
+    resource))
+
+(define-method (cleanup-resource (self <file-resource>))
+  ((if (is-collection? self)
+       rmdir
+       delete-file)
+   (filepath self)))
+
+(define-method (content-length (self <file-resource>))
+  (-> (filepath self) stat stat:size))
+
+
+(define-method (getcontenttype (self <file-resource>))
+  ;; TODO 404 if collection
+  ;; Or just omit it?
+  (propstat 200 `((,(xml webdav 'getcontenttype)
+                   ,(mimetype (filepath self))))))
+
+(define-method (getlastmodified (self <file-resource>))
+  (propstat 200
+            `((,(xml webdav 'getlastmodified)
+               ,(with-locale1
+                 LC_TIME "C"
+                 (lambda ()
+                  (-> (filepath self)
+                      stat
+                      stat:mtime
+                      unix-time->datetime
+                      (datetime->string "~a, ~d ~b ~Y ~H:~M:~S GMT"))))))))
+
+;; (define (xattr-key xml-el)
+;;   (format #f "caldav.~a"
+;;           (base64-encode
+;;            (format #f "~a:~a"
+;;                    (xml-element-namespace xml-el)
+;;                    (xml-element-tagname xml-el)))))
+
+
+;; (define-method (set-dead-property (self <file-resource>) value)
+;;   (unless (and (list? value)
+;;                (xml-element? (car value)))
+;;     (scm-error 'misc-error "set-dead-property"
+;;                "Invalid value, expected namespaced sxml"
+;;                '() #f))
+;;   (catch #t
+;;     (lambda ()
+;;       (lambda ()
+;;         (xattr-set!
+;;          (filename self)
+;;          (xattr-key (car value))
+;;          (with-output-to-string
+;;            (lambda () (namespaced-sxml->xml value))))))
+;;     (lambda _ (next-method))))
+
+
+;; (define-method (get-dead-property (self <file-resource>)
+;;                            xml-el)
+;;   (catch #t
+;;     (lambda ()
+;;       (propstat 200
+;;                 (list
+;;                  (xattr-ref (filepath self)
+;;                             (xattr-key el)))))
+;;     (lambda _ (next-method))))
+
+
+;; (define-method (remove-dead-property (self <file-resource>)
+;;                               xml-el)
+;;   (catch #t
+;;     (lambda () (xattr-remove! (filepath self) xml-el))
+;;     (lambda _ (next-method))))
diff --git a/module/calp/webdav/resource/virtual.scm b/module/calp/webdav/resource/virtual.scm
new file mode 100644
index 00000000..2fcaa76a
--- /dev/null
+++ b/module/calp/webdav/resource/virtual.scm
@@ -0,0 +1,70 @@
+(define-module (calp webdav resource virtual)
+  :use-module (oop goops)
+  :use-module (datetime)
+  :use-module (rnrs bytevectors)
+  :use-module (hnh util)
+  :use-module (sxml namespaced)
+  :use-module (calp webdav resource)
+  :use-module (calp webdav property)
+  :use-module (calp namespaces)
+  :export (<virtual-resource>
+           virtual-resource?
+           virtual-ns
+           ;; content
+           isvirtual
+           )
+  )
+
+(define virtual-ns (string->symbol "http://example.com/virtual"))
+
+(define-class <virtual-resource> (<resource>)
+  (content* init-value: #vu8()
+           init-keyword: content:
+           accessor: content*)
+  (creation-time init-form: (current-datetime)
+                 init-keyword: creation-time:
+                 getter: creation-time))
+
+(define (virtual-resource? x)
+  (is-a? x <virtual-resource>))
+
+(define-method (write (self <virtual-resource>) port)
+  (format port "#<<virtual-resource> name=~s, creation-time=~s, content=~s>"
+          (name self)
+          (creation-time self)
+          (content self)))
+
+(define-method (live-properties (self <virtual-resource>))
+  (append
+   (next-method)
+   (list (cons (xml-element-hash-key (xml virtual-ns 'isvirtual)) (make-live-property isvirtual set-isvirtual!)))))
+
+(define-method (content (self <virtual-resource>))
+  (content* self))
+
+(define-method (set-content! (self <virtual-resource>) data)
+  (set! (content* self) data))
+
+(define-method (creationdate (self <virtual-resource>))
+  (propstat 200
+            (list
+             (list (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"))))
+
+(define-method (isvirtual (self <virtual-resource>))
+  (propstat 200
+            (list
+             (list (xml virtual-ns 'isvirtual)
+                   "true"))))
+
+
+(define-method (set-isvirtual! (self <virtual-resource>) _)
+  (throw 'protected-resource "isvirtual"))
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)))))