source: project/release/4/xml-rpc/trunk/tests/run.scm @ 15214

Last change on this file since 15214 was 15214, checked in by sjamaan, 11 years ago

Implement new, properly tested, version of xml-rpc based on http-client and sxpath. TODO: documentation and xml-rpc-server module

File size: 11.0 KB
Line 
1(use test)
2;; Should use numbers, but that's a whole new can of worms...
3
4(load "../xml-rpc-lolevel")
5(import xml-rpc-lolevel)
6
7(test-group "Marshaling"
8  (test "integer"
9        `(i4 "1")
10        (value->xml-rpc-fragment 1))
11  (test "double"
12        `(double "1.2345")
13        (value->xml-rpc-fragment 1.2345))
14  (test "double exact->inexact"
15        `(double ,(number->string (exact->inexact 1/3)))
16        (value->xml-rpc-fragment 1/3))
17  (test "empty string" 
18        `(string "") ;; Or (string) ?
19        (value->xml-rpc-fragment ""))
20  (test "string"
21        `(string "fubar")
22        (value->xml-rpc-fragment "fubar"))
23  (test "empty symbol"
24        `(string "") ;; Or (string) ?
25        (value->xml-rpc-fragment '||))
26  (test "symbol"
27        `(string "fubar")
28        (value->xml-rpc-fragment 'fubar))
29  (test "empty u8vector"
30        `(base64 "")
31        (value->xml-rpc-fragment (u8vector)))
32  (test "u8vector"
33        `(base64 "YWJj")
34        (value->xml-rpc-fragment (u8vector 97 98 99)))
35  (test "empty blob"
36        `(base64 "")
37        (value->xml-rpc-fragment (string->blob "")))
38  (test "blob"
39        `(base64 "YWJj")
40        (value->xml-rpc-fragment (string->blob "abc")))
41  (test "empty vector"
42        `(array (data))
43        (value->xml-rpc-fragment (vector)))
44  (test "vector"
45        `(array (data
46                 (value (string "one"))
47                 (value (i4 "2"))))
48        (value->xml-rpc-fragment (vector "one" 2)))
49  (test "nested vector"
50        `(array (data
51                 (value (array (data (value (string "one")))))))
52        (value->xml-rpc-fragment (vector (vector "one"))))
53  (test "empty list"
54        `(array (data))
55        (value->xml-rpc-fragment '()))
56  (test "list"
57        `(array (data
58                 (value (string "one"))
59                 (value (i4 "2"))))
60        (value->xml-rpc-fragment '("one" 2)))
61  (test "nested list"
62        `(array (data
63                 (value (array (data (value (string "one")))))))
64        (value->xml-rpc-fragment '(("one")))) 
65  (test "empty hash table"
66        `(struct)
67        (value->xml-rpc-fragment (alist->hash-table `())))
68  (test "simple hash table"
69        ;; XXX: Hash ordering can change! Test is too specific
70        `(struct
71          (member
72           (name "qux")
73           (value (i4 "1")))
74          (member
75           (name "foo")
76           (value (string "bar"))))
77        (value->xml-rpc-fragment
78         (alist->hash-table `((qux . 1) (foo . "bar")))))
79  (test "nested hash table"
80        `(struct
81          (member
82           (name "foo")
83           (value (struct
84                   (member
85                    (name "bar")
86                    (value (string "qux")))))))
87        (value->xml-rpc-fragment
88         (alist->hash-table `((foo . ,(alist->hash-table `((bar . "qux"))))))))
89  (test "hash table with vector array"
90        `(struct
91          (member
92           (name "foo")
93           (value (array
94                   (data
95                    (value (string "bar"))
96                    (value (string "qux")))))))
97        (value->xml-rpc-fragment
98         (alist->hash-table `((foo . ,(vector "bar" "qux"))))))
99  (test "vector array with hash tables"
100        `(array
101          (data
102           (value
103            (struct
104             (member
105              (name "foo")
106              (value (string "bar")))))
107           (value
108            (struct
109             (member
110              (name "qux")
111              (value (string "mooh")))))))
112        (value->xml-rpc-fragment
113         (vector (alist->hash-table `((foo . "bar")))
114                 (alist->hash-table `((qux . "mooh"))))))
115  (test "simple alist"
116        `(struct
117          (member
118           (name "qux")
119           (value (i4 "1")))
120          (member
121           (name "foo")
122           (value (string "bar"))))
123        (value->xml-rpc-fragment `((qux . 1) (foo . "bar"))))
124  (test "nested alist"
125        `(struct
126          (member
127           (name "foo")
128           (value (struct
129                   (member
130                    (name "bar")
131                    (value (string "qux")))))))
132        (value->xml-rpc-fragment `((foo . ((bar . "qux"))))))
133  (test "alist with vector array"
134        `(struct
135          (member
136           (name "foo")
137           (value (array
138                   (data
139                    (value (string "bar"))
140                    (value (string "qux")))))))
141        (value->xml-rpc-fragment `((foo . ,(vector "bar" "qux")))))
142  (test "vector array with alist"
143        `(array
144          (data
145           (value
146            (struct
147             (member
148              (name "foo")
149              (value (string "bar")))))
150           (value
151            (struct
152             (member
153              (name "qux")
154              (value (string "mooh")))))))
155        (value->xml-rpc-fragment
156         (vector '((foo . "bar")) '((qux . "mooh")))))
157  (test "ISO8601"
158        `(dateTime.iso8601 "19980717T14:08:55")
159        (parameterize ((xml-rpc-unparsers
160                        `((,vector? . ,vector->xml-rpc-iso8601))))
161          (value->xml-rpc-fragment (vector 55 8 14 17 6 98 0 0 #f 0))))
162  (define-record foo bar)
163  (test-error "unknown type gives error"
164              (value->xml-rpc-fragment (make-foo 1))))
165
166(test-group "Unmarshaling"
167  (test "integer (i4)"
168        123
169        (xml-rpc-fragment->value `(i4 "123")))
170  (test "integer (int)"
171        123
172        (xml-rpc-fragment->value `(int "123")))
173  (test "double"
174        123.456
175        (xml-rpc-fragment->value `(double "123.456")))
176  (test "boolean false"
177        #f
178        (xml-rpc-fragment->value `(boolean "0")))
179  (test "boolean true (correct)"
180        #t
181        (xml-rpc-fragment->value `(boolean "1")))
182  (test "boolean true (liberal)"
183        #t
184        (xml-rpc-fragment->value `(boolean "2")))
185  (test "empty string"
186        ""
187        (xml-rpc-fragment->value `(string)))
188  (test "empty string (explicit data)"
189        ""
190        (xml-rpc-fragment->value `(string "")))
191  (test "base64"
192        (u8vector 97 98 99)
193        (xml-rpc-fragment->value `(base64 "YWJj")))
194  (test "empty array"
195        (vector)
196        (xml-rpc-fragment->value `(array (data))))
197  (test "simple array"
198        (vector 1 "abc")
199        (xml-rpc-fragment->value `(array (data (value (int "1"))
200                                               (value (string "abc"))))))
201  (test "nested array"
202        (vector (vector 1 2) (vector "abc" "def") "ghi")
203        (xml-rpc-fragment->value `(array (data
204                                          (value (array
205                                                  (data
206                                                   (value (int "1"))
207                                                   (value (int "2")))))
208                                          (value (array
209                                                  (data
210                                                   (value (string "abc"))
211                                                   (value (string "def")))))
212                                          (value (string "ghi"))))))
213  (test "nasty nested array with attrs"
214        (vector (vector 1 2) (vector "abc" "def") "ghi")
215        (xml-rpc-fragment->value `(array (@ (type "list"))
216                                         (data (@ (type "nested"))
217                                          (value (array
218                                                  (data (@ (type "flat"))
219                                                   (value (int
220                                                           (@ (bit "signed"))
221                                                           "1"))
222                                                   (value (int "2")))))
223                                          (value (array
224                                                  (data
225                                                   (value (string "abc"))
226                                                   (value (string "def")))))
227                                          (value (string "ghi"))))))
228  (test "empty struct"
229        (alist->hash-table '())
230        (xml-rpc-fragment->value `(struct)))
231  (test "simple struct"
232        (alist->hash-table '((foo . "bar")))
233        (xml-rpc-fragment->value `(struct (member (name "foo")
234                                                  (value (string "bar"))))))
235  (test "simple struct - rearranged name/value"
236        (alist->hash-table '((foo . "bar")))
237        (xml-rpc-fragment->value `(struct (member (value (string "bar"))
238                                                  (name "foo")))))
239  (test "nested struct"
240        (alist->hash-table `((foo . ,(alist->hash-table '((bar . "qux"))))))
241        (xml-rpc-fragment->value `(struct
242                                   (member
243                                    (name "foo")
244                                    (value (struct
245                                            (member
246                                             (name "bar")
247                                             (value (string "qux")))))))))
248  (test "nasty nested struct with attrs"
249        (alist->hash-table `((foo . ,(alist->hash-table '((bar . "qux"))))))
250        (xml-rpc-fragment->value `(struct (@ (lang "en"))
251                                   (member
252                                    (name (@ (dir "rtl")) "foo")
253                                    (value (@ (type "dictionary"))
254                                           (struct
255                                            (member
256                                             (name "bar")
257                                             (value (string "qux")))))))))
258  ;; Try other different notations (ISO8601 has a variety of notations)
259  (test "datetime"
260        (vector 55 8 14 17 6 98 0 0 #f 0)
261        (xml-rpc-fragment->value
262         `(dateTime.iso8601 "19980717T14:08:55"))))
263
264(load "../xml-rpc-client")
265(import xml-rpc-client)
266
267(test-group "response handling"
268  (test "simple response"
269        '("test")
270        (receive params
271          (handle-xml-rpc-response
272          `(*TOP*
273            (*PI* xml "version=\"1.0\"")
274            (methodResponse
275             (params
276              (param (value (string "test")))))))
277          params))
278  (test "multi-param response (chicken extension)"
279        '("test" 1 2 3)
280        (receive params
281          (handle-xml-rpc-response
282           `(*TOP*
283             (*PI* xml "version=\"1.0\"")
284             (methodResponse
285              (params
286               (param (value (string "test")))
287               (param (value (i4 "1")))
288               (param (value (int "2")))
289               (param (value (int "3")))))))
290          params))
291  (test-error "fault code throws exception"
292              (receive params
293                (handle-xml-rpc-response
294                 `(*TOP*
295                   (*PI* xml "version=\"1.0\"")
296                   (methodResponse
297                    (fault
298                     (value (struct
299                             (member
300                              (name "faultCode")
301                              (value (int "10")))
302                             (member
303                              (name "faultString")
304                              (value (string "there was an error")))))))))
305                params)))
Note: See TracBrowser for help on using the repository browser.