diff options
Diffstat (limited to 'tests/unit/webdav')
| -rw-r--r-- | tests/unit/webdav/webdav-file.scm | 56 | ||||
| -rw-r--r-- | tests/unit/webdav/webdav-server.scm | 353 | ||||
| -rw-r--r-- | tests/unit/webdav/webdav-tree.scm | 92 | ||||
| -rw-r--r-- | tests/unit/webdav/webdav-util.scm | 31 | ||||
| -rw-r--r-- | tests/unit/webdav/webdav.scm | 359 |
5 files changed, 891 insertions, 0 deletions
diff --git a/tests/unit/webdav/webdav-file.scm b/tests/unit/webdav/webdav-file.scm new file mode 100644 index 00000000..85f4738d --- /dev/null +++ b/tests/unit/webdav/webdav-file.scm @@ -0,0 +1,56 @@ +(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) + +'((calp webdav resource) + (calp webdav resource file)) diff --git a/tests/unit/webdav/webdav-server.scm b/tests/unit/webdav/webdav-server.scm new file mode 100644 index 00000000..d5fa0e93 --- /dev/null +++ b/tests/unit/webdav/webdav-server.scm @@ -0,0 +1,353 @@ +(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")) + ;; Extra child added to ensure deep copy works + (add-resource! a "d" "Content of d")) + + (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" "/a/d" "/c" + ;; New resources. Note that /c/c doesn't create an infinite loop + "/c/a" "/c/a/d" "/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 + +'((calp server webdav)) diff --git a/tests/unit/webdav/webdav-tree.scm b/tests/unit/webdav/webdav-tree.scm new file mode 100644 index 00000000..da6073eb --- /dev/null +++ b/tests/unit/webdav/webdav-tree.scm @@ -0,0 +1,92 @@ +(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))) + ) + +'((calp webdav resource) + (calp webdav resource virtual) + (calp webdav resource file)) diff --git a/tests/unit/webdav/webdav-util.scm b/tests/unit/webdav/webdav-util.scm new file mode 100644 index 00000000..c4e16536 --- /dev/null +++ b/tests/unit/webdav/webdav-util.scm @@ -0,0 +1,31 @@ +(define-module (test webdav-util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp webdav resource base)) + +(test-group "string->href" + (test-equal "Root path becomes null" + '() (string->href "/")) + (test-equal "Trailing slashes are ignored" + '("a" "b") (string->href "/a/b/"))) + +(test-group "href->string" + (test-equal "Null case becomes root path" + "/" (href->string '())) + (test-equal "Trailing slashes are not added" + "/a/b" (href->string '("a" "b")))) + +(test-group "href-relative" + (test-equal '("a" "b") (href-relative '() '("a" "b"))) + (test-equal '("b") (href-relative '("a") '("a" "b"))) + (test-equal '() (href-relative '("a" "b") '("a" "b"))) + + (test-error 'misc-error + (href-relative '("c") '("a" "b"))) + + (test-error 'misc-error + (href-relative '("c") '()))) + +'((calp webdav resource base)) diff --git a/tests/unit/webdav/webdav.scm b/tests/unit/webdav/webdav.scm new file mode 100644 index 00000000..e86b5342 --- /dev/null +++ b/tests/unit/webdav/webdav.scm @@ -0,0 +1,359 @@ +(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 `(,(xml webdav 'propfind) + (,(xml webdav 'propname))) + 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 `((xml webdav 'propfind) + (,(xml webdav 'prop) + (,(xml webdav 'displayname)))) + 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 `(,(xml webdav 'propfind) + (,(xml webdav 'allprop))) + resource))) + + + (test-equal "Propfind result" + (list + (propstat 200 + (list (list (xml webdav 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + (list (xml webdav 'getcontentlength) + 4) + (list (xml webdav 'getcontenttype) + "application/binary") + (list (xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + (list (xml webdav 'lockdiscovery) '()) + (list (xml webdav 'resourcetype) + ; (list (xml webdav '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 `((xml webdav 'propfind) + (,(xml webdav 'allprop)) + (,(xml webdav 'include))) + resource))) + + + (test-equal "Include NOTHING" + (list + (propstat 200 + (list (list (xml webdav 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + (list (xml webdav 'getcontentlength) + 4) + (list (xml webdav 'getcontenttype) + "application/binary") + (list (xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + (list (xml webdav 'lockdiscovery) '()) + (list (xml webdav 'resourcetype) + ; (list (xml webdav '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 `(,(xml webdav 'propfind) + (,(xml webdav 'allprop)) + (,(xml webdav 'include) + (,(xml virtual-ns 'isvirtual)))) + resource))) + + (test-equal "Include isvirtual" + (list + (propstat 200 + (list (list (xml webdav 'creationdate) (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + (list (xml webdav 'getcontentlength) 4) + (list (xml webdav 'getcontenttype) "application/binary") + (list (xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") + (list (xml virtual-ns 'isvirtual) "true") + (list (xml webdav 'lockdiscovery) '()) + (list (xml webdav 'resourcetype)) + (list (xml webdav 'supportedlock) '()) + (list (xml 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 (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>"))) + + (sort-propstats (parse-propfind (caddr request) 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))))) + + +'((calp webdav property) + (calp webdav propfind) + (calp webdav resource) + (calp webdav resource virtual)) |