From 00a66eca0f32fcf585d2c21375641020e877e3ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 13 Dec 2023 11:06:57 +0100 Subject: Update things depending on namespaced sxml. Update all code to emit correctly formed namespaced sxml objects, instead of the old list based approach. Also introduces a number of typechecks which in semi-related parts of the code. Note that the webdav-server test is currently broken. --- tests/unit/sxml/sxml-namespaced.scm | 24 +++++- tests/unit/webdav/webdav-file.scm | 1 + tests/unit/webdav/webdav-property.scm | 28 +++--- tests/unit/webdav/webdav-propfind.scm | 157 ++++++++++++++++------------------ tests/unit/webdav/webdav-resource.scm | 28 +++--- 5 files changed, 126 insertions(+), 112 deletions(-) (limited to 'tests') diff --git a/tests/unit/sxml/sxml-namespaced.scm b/tests/unit/sxml/sxml-namespaced.scm index 18e35225..ee1407d6 100644 --- a/tests/unit/sxml/sxml-namespaced.scm +++ b/tests/unit/sxml/sxml-namespaced.scm @@ -42,6 +42,18 @@ ;;; TODO Attributes ;;; TODO children +(test-group "Constructing XML documents" + (test-assert "With simple content" + ((xml 'a) "Hello")) + + (test-assert "Full document" + ((xml 'html) + ((xml 'head) + ((xml #f 'meta '((charset "UTF-8")))) + ((xml 'title) "Title text")) + ((xml 'body) + "This document left blank")))) + (test-group "xml->namespaced-sxml" @@ -73,7 +85,7 @@ root: ((xml 'tag))) (xml->namespaced-sxml "")) - (test-equal "Document with whitespace in it" + (test-equal "Document with (untrimmed) whitespace in it" (xml-document pi: (list (pi-element 'xml "")) root: ((xml 'root) @@ -82,6 +94,16 @@ (xml->namespaced-sxml " " trim-whitespace?: #f)) + ;; An earlier version trimmed whitespace down inte empty strings, + ;; instead of (correctly) omitting the strings completely. + (test-equal "Document with (trimmed) whitespace in it" + (xml-document + pi: (list (pi-element 'xml "")) + root: ((xml 'root) + ((xml 'a)))) + (xml->namespaced-sxml " " + trim-whitespace?: #t)) + (test-equal "Whitespace before root is discarded kept" (xml-document pi: (list (pi-element 'xml "")) diff --git a/tests/unit/webdav/webdav-file.scm b/tests/unit/webdav/webdav-file.scm index 85f4738d..cc7c98dd 100644 --- a/tests/unit/webdav/webdav-file.scm +++ b/tests/unit/webdav/webdav-file.scm @@ -20,6 +20,7 @@ (define test-root (mkdtemp (string-copy "/tmp/calp-test-XXXXXX"))) (define root-resource (make + name: "*root*" root: test-root)) diff --git a/tests/unit/webdav/webdav-property.scm b/tests/unit/webdav/webdav-property.scm index 0b465e82..b3edf7ac 100644 --- a/tests/unit/webdav/webdav-property.scm +++ b/tests/unit/webdav/webdav-property.scm @@ -25,34 +25,34 @@ ;; (test-equal "/" (href->string (href resource))) (test-equal "Basic propstat" - (propstat 200 (list (list (xml webdav 'getcontentlength) 4))) + (propstat 200 (list ((xml webdav 'getcontentlength) "4"))) (getcontentlength resource)) ;;; 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")))))) +(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")))) + (list ((xml webdav 'getcontenttype) "text/plain") + ((xml webdav 'displayname) "Displayname")))) (merge-propstats ps))) (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")) ))) + ((xml webdav 'propstat) + ((xml webdav 'prop) ((xml webdav 'displayname) "test")) + ((xml webdav 'status) "HTTP/1.1 200 OK")) + (propstat->namespaced-sxml (propstat 200 (list ((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")) + ((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 (list ((xml webdav 'displayname) "test")) responsedescription: "Try logging in")))) '((calp webdav property)) diff --git a/tests/unit/webdav/webdav-propfind.scm b/tests/unit/webdav/webdav-propfind.scm index 8144605a..220b84d3 100644 --- a/tests/unit/webdav/webdav-propfind.scm +++ b/tests/unit/webdav/webdav-propfind.scm @@ -17,6 +17,8 @@ (define (sort-symbols symbs) (sort* symbs string<=? symbol->string)) +;;; Propstats are unsorted, we just sort them here for easier +;;; equivalence checks in the tests. (define (sort-propstats propstats) (map (lambda (pr) @@ -24,7 +26,7 @@ (modify pr propstat-property* (lambda (it) (sort* it - string< (compose symbol->string xml-element-tagname car))))) + string< (compose symbol->string xml-element-tagname))))) (sort* propstats < propstat-status-code))) @@ -49,24 +51,25 @@ (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))))) + (xml-element? (car (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))))) + (sort-symbols (map (compose xml-element-tagname car propstat-property) + most))))) (test-equal "propfind-selected-properties" - (list (propstat 404 `((,(xml webdav 'displayname))))) - (propfind-selected-properties resource (list (xml webdav 'displayname)))) + (list (propstat 404 (list ((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))) + (let ((props (parse-propfind ((xml webdav 'propfind) + ((xml webdav 'propname))) resource))) @@ -76,11 +79,8 @@ (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)))) + (test-assert "Each entry is an xml element" (xml-element*? el)) + (test-eqv "The enrties lack children" 0 (length (xml-element-children el)))) (propstat-property (car props))) #; @@ -88,128 +88,119 @@ (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)))) + (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) - )))) + (list (propstat 404 (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))) + (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 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + ((xml webdav 'getcontentlength) + "4") + ((xml webdav 'getcontenttype) + "application/binary") + ((xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + ((xml webdav 'lockdiscovery)) + ((xml webdav 'resourcetype) ; (list (xml webdav 'collection)) - ) - (list (xml webdav 'supportedlock) '()) + ) + ((xml webdav 'supportedlock)) ;; (list (xml ns1 'test) "Content") )) - (propstat 404 (list (list (xml webdav 'displayname)) - (list (xml webdav 'getcontentlanguage)))) + (propstat 404 (list ((xml webdav 'displayname)) + ((xml webdav 'getcontentlanguage)))) (propstat 501 - (list (list (xml webdav 'getetag)) - ))) + (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))) + (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 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + ((xml webdav 'getcontentlength) + "4") + ((xml webdav 'getcontenttype) + "application/binary") + ((xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + ((xml webdav 'lockdiscovery)) + ((xml webdav 'resourcetype) ; (list (xml webdav 'collection)) - ) - (list (xml webdav 'supportedlock) '()) + ) + ((xml webdav 'supportedlock)) ;; (list (xml ns1 'test) "Content") )) - (propstat 404 (list (list (xml webdav 'displayname)) - (list (xml webdav 'getcontentlanguage)))) + (propstat 404 (list ((xml webdav 'displayname)) + ((xml webdav 'getcontentlanguage)))) (propstat 501 - (list (list (xml webdav 'getetag)) + (list ((xml webdav 'getetag)) ))) (sort-propstats props))) - (let ((props (parse-propfind `(,(xml webdav 'propfind) - (,(xml webdav 'allprop)) - (,(xml webdav 'include) - (,(xml virtual-ns 'isvirtual)))) + (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 webdav 'creationdate) (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + ((xml webdav 'getcontentlength) "4") + ((xml webdav 'getcontenttype) "application/binary") + ((xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") + ((xml virtual-ns 'isvirtual) "true") + ((xml webdav 'lockdiscovery)) + ((xml webdav 'resourcetype)) + ((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)) - ))) + (propstat 404 (list ((xml webdav 'displayname)) + ((xml webdav 'getcontentlanguage)))) + (propstat 501 (list ((xml webdav 'getetag))))) (sort-propstats props))))) (test-equal (list (propstat 200 - `((,(xml webdav 'getcontentlength) 4) - (,(xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") - (,(xml webdav 'resourcetype)))) + (list ((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))))) + (list ((xml webdav 'checked-in)) + ((xml webdav 'checked-out)) + ((xml (string->symbol "http://apache.org/dav/props/") 'executable))))) (let ((request (xml->namespaced-sxml " @@ -223,7 +214,7 @@ "))) - (sort-propstats (parse-propfind (caddr request) resource)))) + (sort-propstats (parse-propfind (xml-document-root request) resource)))) (test-equal "All dead properties" (list #; diff --git a/tests/unit/webdav/webdav-resource.scm b/tests/unit/webdav/webdav-resource.scm index f6ebf3bb..f81487ed 100644 --- a/tests/unit/webdav/webdav-resource.scm +++ b/tests/unit/webdav/webdav-resource.scm @@ -52,7 +52,7 @@ (let ((props (live-properties resource))) (test-assert (list? props)) (for-each (lambda (pair) - ;; (test-assert (xml-element? (car 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))))) @@ -61,36 +61,36 @@ (define ns1 (string->symbol "http://example.com/namespace")) -(set-dead-property! resource `(,(xml ns1 'test) "Content")) +(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))) + (propstat 200 (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))) + (propstat 404 (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))) + (propstat 200 (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)))) + (propstat 404 (list ((xml ns1 'test2)))) + (get-property resource ((xml ns1 'test2))))) (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))) + (propstat 404 (list ((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)))) + (propstat 404 (list ((xml webdav 'displayname)))) + (get-property resource ((xml webdav 'displayname))))) (test-group "lookup-resource" (let* ((root (make name: "*root*")) -- cgit v1.2.3