From 712654d4c023a2ab13190c6905d313e0ba897965 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 2 Oct 2023 19:26:40 +0200 Subject: Rewrite test running system. --- tests/test/webdav-server.scm | 351 ------------------------------------------- 1 file changed, 351 deletions(-) delete mode 100644 tests/test/webdav-server.scm (limited to 'tests/test/webdav-server.scm') 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 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 " - - -")) - (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 " - - - - New Displayname - - - - -" 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 " - - - - - -" 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 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 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 -- cgit v1.2.3