blob: f81487ed9d1221d8178fc984924e5c9c3a25fb18 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
(define-module (test webdav-resource)
:use-module ((calp namespaces) :select (webdav))
:use-module ((calp webdav property) :select (propstat))
:use-module (calp webdav resource base)
:use-module (calp webdav resource virtual)
:use-module (calp webdav resource)
:use-module (datetime)
:use-module (oop goops)
:use-module (srfi srfi-64)
:use-module (srfi srfi-64 test-error)
:use-module (srfi srfi-71)
:use-module (srfi srfi-88)
:use-module (sxml namespaced)
)
(define dt
(datetime year: 2010 month: 11 day: 12
hour: 13 minute: 14 hour: 15))
(define resource (make <virtual-resource>
;; local-path: '("")
name: "*root"
content: #vu8(1 2 3 4)
creation-time: dt))
(test-group "string->href"
(test-equal "Root path becomes null"
'() (string->href "/"))
(test-equal "Trailing slashes are ignored"
'("a" "b") (string->href "/a/b/")))
(test-group "href->string"
(test-equal "Null case becomes root path"
"/" (href->string '()))
(test-equal "Trailing slashes are not added"
"/a/b" (href->string '("a" "b"))))
(test-group "href-relative"
(test-equal '("a" "b") (href-relative '() '("a" "b")))
(test-equal '("b") (href-relative '("a") '("a" "b")))
(test-equal '() (href-relative '("a" "b") '("a" "b")))
(test-error 'misc-error
(href-relative '("c") '("a" "b")))
(test-error 'misc-error
(href-relative '("c") '())))
(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)))
(define ns1 (string->symbol "http://example.com/namespace"))
(set-dead-property! resource ((xml ns1 'test) "Content"))
(test-equal "Get dead property"
(propstat 200 (list ((xml ns1 'test) "Content")))
(get-dead-property resource ((xml ns1 'test))))
(test-equal "Get live property"
(propstat 404 (list ((xml ns1 'test))))
(get-live-property resource ((xml ns1 'test))))
(test-group "Dead properties"
(test-equal "Existing property"
(propstat 200 (list ((xml ns1 'test) "Content")))
(get-property resource ((xml ns1 'test))))
(test-equal "Missing property"
(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 (list ((xml webdav 'displayname))))
(get-live-property resource ((xml webdav 'displayname))))
(test-equal "Existing live property (thrtough get-property)"
(propstat 404 (list ((xml webdav 'displayname))))
(get-property resource ((xml webdav 'displayname)))))
(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"))))))
'((calp webdav resource)
(calp webdav resource base))
|
