aboutsummaryrefslogtreecommitdiff
path: root/tests/test/webdav-server.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tests/test/webdav-server.scm')
-rw-r--r--tests/test/webdav-server.scm349
1 files changed, 349 insertions, 0 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-02 03:33:08 +0200