aboutsummaryrefslogtreecommitdiff
path: root/tests/test/webdav.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tests/test/webdav.scm')
-rw-r--r--tests/test/webdav.scm353
1 files changed, 0 insertions, 353 deletions
diff --git a/tests/test/webdav.scm b/tests/test/webdav.scm
deleted file mode 100644
index 0962a89e..00000000
--- a/tests/test/webdav.scm
+++ /dev/null
@@ -1,353 +0,0 @@
-(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)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 10:37:36 +0200