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.scm351
1 files changed, 0 insertions, 351 deletions
diff --git a/tests/test/webdav-server.scm b/tests/test/webdav-server.scm
deleted file mode 100644
index 67747de7..00000000
--- a/tests/test/webdav-server.scm
+++ /dev/null
@@ -1,351 +0,0 @@
-(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
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 10:12:41 +0200