diff options
Diffstat (limited to '')
-rw-r--r-- | Makefile | 4 | ||||
-rw-r--r-- | doc/ref/guile.texi | 1 | ||||
-rw-r--r-- | doc/ref/guile/webdav.texi | 289 | ||||
-rw-r--r-- | module/calp/namespaces.scm | 14 | ||||
-rw-r--r-- | module/calp/server/webdav.scm | 736 | ||||
-rw-r--r-- | module/calp/webdav/property.scm | 91 | ||||
-rw-r--r-- | module/calp/webdav/propfind.scm | 93 | ||||
-rw-r--r-- | module/calp/webdav/proppatch.scm | 67 | ||||
-rw-r--r-- | module/calp/webdav/resource.scm | 15 | ||||
-rw-r--r-- | module/calp/webdav/resource/base.scm | 572 | ||||
-rw-r--r-- | module/calp/webdav/resource/calendar.scm | 129 | ||||
-rw-r--r-- | module/calp/webdav/resource/file.scm | 188 | ||||
-rw-r--r-- | module/calp/webdav/resource/virtual.scm | 70 | ||||
-rwxr-xr-x | tests/litmus.scm | 80 | ||||
-rw-r--r-- | tests/test/webdav-file.scm | 53 | ||||
-rw-r--r-- | tests/test/webdav-server.scm | 349 | ||||
-rw-r--r-- | tests/test/webdav-tree.scm | 89 | ||||
-rw-r--r-- | tests/test/webdav.scm | 354 |
18 files changed, 3194 insertions, 0 deletions
@@ -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))))) |