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

Last change on this file since 15250 was 15250, checked in by sjamaan, 12 years ago

Implement a simple xml-rpc procedure

File size: 17.9 KB
Line 
1(use test ssax intarweb sxpath-lolevel)
2;; Should use numbers, but that's a whole new can of worms...
3
4(load "../xml-rpc-lolevel")
5(load "../xml-rpc-client")
6(load "../xml-rpc-server")
7(import xml-rpc-lolevel)
8(import xml-rpc-client)
9(import xml-rpc-server)
10
11(test-group "Marshaling"
12  (test "integer"
13        `(i4 "1")
14        (value->xml-rpc-fragment 1))
15  (test "double"
16        `(double "1.2345")
17        (value->xml-rpc-fragment 1.2345))
18  (test "double exact->inexact"
19        `(double ,(number->string (exact->inexact 1/3)))
20        (value->xml-rpc-fragment 1/3))
21  (test "empty string" 
22        `(string "") ;; Or (string) ?
23        (value->xml-rpc-fragment ""))
24  (test "string"
25        `(string "fubar")
26        (value->xml-rpc-fragment "fubar"))
27  (test "empty symbol"
28        `(string "") ;; Or (string) ?
29        (value->xml-rpc-fragment '||))
30  (test "symbol"
31        `(string "fubar")
32        (value->xml-rpc-fragment 'fubar))
33  (test "empty u8vector"
34        `(base64 "")
35        (value->xml-rpc-fragment (u8vector)))
36  (test "u8vector"
37        `(base64 "YWJj")
38        (value->xml-rpc-fragment (u8vector 97 98 99)))
39  (test "empty blob"
40        `(base64 "")
41        (value->xml-rpc-fragment (string->blob "")))
42  (test "blob"
43        `(base64 "YWJj")
44        (value->xml-rpc-fragment (string->blob "abc")))
45  (test "empty vector"
46        `(array (data))
47        (value->xml-rpc-fragment (vector)))
48  (test "vector"
49        `(array (data
50                 (value (string "one"))
51                 (value (i4 "2"))))
52        (value->xml-rpc-fragment (vector "one" 2)))
53  (test "nested vector"
54        `(array (data
55                 (value (array (data (value (string "one")))))))
56        (value->xml-rpc-fragment (vector (vector "one"))))
57  (test "empty list"
58        `(array (data))
59        (value->xml-rpc-fragment '()))
60  (test "list"
61        `(array (data
62                 (value (string "one"))
63                 (value (i4 "2"))))
64        (value->xml-rpc-fragment '("one" 2)))
65  (test "nested list"
66        `(array (data
67                 (value (array (data (value (string "one")))))))
68        (value->xml-rpc-fragment '(("one")))) 
69  (test "empty hash table"
70        `(struct)
71        (value->xml-rpc-fragment (alist->hash-table `())))
72  (test "simple hash table"
73        ;; XXX: Hash ordering can change! Test is too specific
74        `(struct
75          (member
76           (name "qux")
77           (value (i4 "1")))
78          (member
79           (name "foo")
80           (value (string "bar"))))
81        (value->xml-rpc-fragment
82         (alist->hash-table `((qux . 1) (foo . "bar")))))
83  (test "nested hash table"
84        `(struct
85          (member
86           (name "foo")
87           (value (struct
88                   (member
89                    (name "bar")
90                    (value (string "qux")))))))
91        (value->xml-rpc-fragment
92         (alist->hash-table `((foo . ,(alist->hash-table `((bar . "qux"))))))))
93  (test "hash table with vector array"
94        `(struct
95          (member
96           (name "foo")
97           (value (array
98                   (data
99                    (value (string "bar"))
100                    (value (string "qux")))))))
101        (value->xml-rpc-fragment
102         (alist->hash-table `((foo . ,(vector "bar" "qux"))))))
103  (test "vector array with hash tables"
104        `(array
105          (data
106           (value
107            (struct
108             (member
109              (name "foo")
110              (value (string "bar")))))
111           (value
112            (struct
113             (member
114              (name "qux")
115              (value (string "mooh")))))))
116        (value->xml-rpc-fragment
117         (vector (alist->hash-table `((foo . "bar")))
118                 (alist->hash-table `((qux . "mooh"))))))
119  (test "simple alist"
120        `(struct
121          (member
122           (name "qux")
123           (value (i4 "1")))
124          (member
125           (name "foo")
126           (value (string "bar"))))
127        (value->xml-rpc-fragment `((qux . 1) (foo . "bar"))))
128  (test "nested alist"
129        `(struct
130          (member
131           (name "foo")
132           (value (struct
133                   (member
134                    (name "bar")
135                    (value (string "qux")))))))
136        (value->xml-rpc-fragment `((foo . ((bar . "qux"))))))
137  (test "alist with vector array"
138        `(struct
139          (member
140           (name "foo")
141           (value (array
142                   (data
143                    (value (string "bar"))
144                    (value (string "qux")))))))
145        (value->xml-rpc-fragment `((foo . ,(vector "bar" "qux")))))
146  (test "vector array with alist"
147        `(array
148          (data
149           (value
150            (struct
151             (member
152              (name "foo")
153              (value (string "bar")))))
154           (value
155            (struct
156             (member
157              (name "qux")
158              (value (string "mooh")))))))
159        (value->xml-rpc-fragment
160         (vector '((foo . "bar")) '((qux . "mooh")))))
161  (test "ISO8601"
162        `(dateTime.iso8601 "19980717T14:08:55")
163        (parameterize ((xml-rpc-unparsers
164                        `((,vector? . ,vector->xml-rpc-iso8601))))
165          (value->xml-rpc-fragment (vector 55 8 14 17 6 98 0 0 #f 0))))
166  (define-record foo bar)
167  (test-error "unknown type gives error"
168              (value->xml-rpc-fragment (make-foo 1))))
169
170(test-group "Unmarshaling"
171  (test "integer (i4)"
172        123
173        (xml-rpc-fragment->value `(i4 "123")))
174  (test "integer (int)"
175        123
176        (xml-rpc-fragment->value `(int "123")))
177  (test "double"
178        123.456
179        (xml-rpc-fragment->value `(double "123.456")))
180  (test "boolean false"
181        #f
182        (xml-rpc-fragment->value `(boolean "0")))
183  (test "boolean true (correct)"
184        #t
185        (xml-rpc-fragment->value `(boolean "1")))
186  (test "boolean true (liberal)"
187        #t
188        (xml-rpc-fragment->value `(boolean "2")))
189  (test "empty string"
190        ""
191        (xml-rpc-fragment->value `(string)))
192  (test "empty string (explicit data)"
193        ""
194        (xml-rpc-fragment->value `(string "")))
195  (test "base64"
196        (u8vector 97 98 99)
197        (xml-rpc-fragment->value `(base64 "YWJj")))
198  (test "empty array"
199        (vector)
200        (xml-rpc-fragment->value `(array (data))))
201  (test "simple array"
202        (vector 1 "abc")
203        (xml-rpc-fragment->value `(array (data (value (int "1"))
204                                               (value (string "abc"))))))
205  (test "nested array"
206        (vector (vector 1 2) (vector "abc" "def") "ghi")
207        (xml-rpc-fragment->value `(array (data
208                                          (value (array
209                                                  (data
210                                                   (value (int "1"))
211                                                   (value (int "2")))))
212                                          (value (array
213                                                  (data
214                                                   (value (string "abc"))
215                                                   (value (string "def")))))
216                                          (value (string "ghi"))))))
217  (test "nasty nested array with attrs"
218        (vector (vector 1 2) (vector "abc" "def") "ghi")
219        (xml-rpc-fragment->value `(array (@ (type "list"))
220                                         (data (@ (type "nested"))
221                                          (value (array
222                                                  (data (@ (type "flat"))
223                                                   (value (int
224                                                           (@ (bit "signed"))
225                                                           "1"))
226                                                   (value (int "2")))))
227                                          (value (array
228                                                  (data
229                                                   (value (string "abc"))
230                                                   (value (string "def")))))
231                                          (value (string "ghi"))))))
232  (test "empty struct"
233        (alist->hash-table '())
234        (xml-rpc-fragment->value `(struct)))
235  (test "simple struct"
236        (alist->hash-table '((foo . "bar")))
237        (xml-rpc-fragment->value `(struct (member (name "foo")
238                                                  (value (string "bar"))))))
239  (test "simple struct - rearranged name/value"
240        (alist->hash-table '((foo . "bar")))
241        (xml-rpc-fragment->value `(struct (member (value (string "bar"))
242                                                  (name "foo")))))
243  (test "nested struct"
244        (alist->hash-table `((foo . ,(alist->hash-table '((bar . "qux"))))))
245        (xml-rpc-fragment->value `(struct
246                                   (member
247                                    (name "foo")
248                                    (value (struct
249                                            (member
250                                             (name "bar")
251                                             (value (string "qux")))))))))
252  (test "nasty nested struct with attrs"
253        (alist->hash-table `((foo . ,(alist->hash-table '((bar . "qux"))))))
254        (xml-rpc-fragment->value `(struct (@ (lang "en"))
255                                   (member
256                                    (name (@ (dir "rtl")) "foo")
257                                    (value (@ (type "dictionary"))
258                                           (struct
259                                            (member
260                                             (name "bar")
261                                             (value (string "qux")))))))))
262  ;; Try other different notations (ISO8601 has a variety of notations)
263  (test "datetime"
264        (vector 55 8 14 17 6 98 0 0 #f 0)
265        (xml-rpc-fragment->value
266         `(dateTime.iso8601 "19980717T14:08:55"))))
267
268(test-group "response handling"
269  (test "simple response"
270        '("test")
271        (receive params
272          (xml-rpc-response->values
273          `(*TOP*
274            (*PI* xml "version=\"1.0\"")
275            (methodResponse
276             (params
277              (param (value (string "test")))))))
278          params))
279  (test "multi-param response (chicken extension)"
280        '("test" 1 2 3)
281        (receive params
282          (xml-rpc-response->values
283           `(*TOP*
284             (*PI* xml "version=\"1.0\"")
285             (methodResponse
286              (params
287               (param (value (string "test")))
288               (param (value (i4 "1")))
289               (param (value (int "2")))
290               (param (value (int "3")))))))
291          params))
292  (test-error "fault code throws exception"
293              (receive params
294                (xml-rpc-response->values
295                 `(*TOP*
296                   (*PI* xml "version=\"1.0\"")
297                   (methodResponse
298                    (fault
299                     (value (struct
300                             (member
301                              (name "faultCode")
302                              (value (int "10")))
303                             (member
304                              (name "faultString")
305                              (value (string "there was an error")))))))))
306                params)))
307
308(test-group "xml call handling"
309  (test "simple call"
310        '(1 2 3)
311        (call-xml-rpc-proc
312         `(*TOP*
313           (*PI* xml "version=\"1.0\"")
314           (methodCall
315            (methodName "scheme.List")
316            (params
317             (param (value (int "1")))
318             (param (value (int "2")))
319             (param (value (int "3"))))))
320         `((scheme.List . ,list))))
321  (test "empty params"
322        '1
323        (call-xml-rpc-proc
324         `(*TOP*
325           (*PI* xml "version=\"1.0\"")
326           (methodCall
327            (methodName "always-one")
328            (params)))
329         `((always-one . ,(constantly 1)))))
330  (test-error "unknown method"
331              (call-xml-rpc-proc
332               `(*TOP*
333                 (*PI* xml "version=\"1.0\"")
334                 (methodCall
335                  (methodName "scheme.unknown")
336                  (params
337                   (param (value (int "1")))
338                   (param (value (int "2")))
339                   (param (value (int "3"))))))
340               `((scheme.List . ,list))))
341  (test-error "malformed xml error"
342              (call-xml-rpc-proc
343               `(*TOP*
344                 (*PI* xml "version=\"1.0\"")
345                 (methodCall
346                  (params
347                   (param (value (int "1")))
348                   (param (value (int "2")))
349                   (param (value (int "3"))))))
350               `((scheme.List . ,list)))))
351
352(test-group "call to xml conversion"
353  (test "simple call"
354        `(methodResponse
355          (params
356           (param (value (array (data (value (i4 "1"))
357                                      (value (i4 "2"))
358                                      (value (i4 "3"))))))))
359        (xml-rpc-call->xml-rpc-response
360         `(*TOP*
361           (*PI* xml "version=\"1.0\"")
362           (methodCall
363            (methodName "scheme.List")
364            (params
365             (param (value (int "1")))
366             (param (value (int "2")))
367             (param (value (int "3"))))))
368         `((scheme.List . ,list))))
369  (test "unknown procedure"
370        `(methodResponse
371          (fault
372           (value (struct
373                   (member
374                    (name "faultCode")
375                    (value (i4 "1")))
376                   (member
377                    (name "faultString")
378                    (value (string "Unknown procedure \"doesnotexist\"")))))))
379        (xml-rpc-call->xml-rpc-response
380         `(*TOP*
381           (*PI* xml "version=\"1.0\"")
382           (methodCall
383            (methodName "doesnotexist")
384            (params
385             (param (value (int "1")))
386             (param (value (int "2")))
387             (param (value (int "3"))))))
388         `((scheme.List . ,list))))
389  (test "malformed xml"
390        `(methodResponse
391          (fault
392           (value (struct
393                   (member
394                    (name "faultCode")
395                    (value (i4 "2")))
396                   (member
397                    (name "faultString")
398                    (value (string "Bad request XML")))))))
399        (xml-rpc-call->xml-rpc-response
400         `(*TOP*
401           (*PI* xml "version=\"1.0\"")
402           (somethingFubar
403            (methodName "scheme.List")
404            (params
405             (param (value (int "1")))
406             (param (value (int "2")))
407             (param (value (int "3"))))))
408         `((scheme.List . ,list))))
409  (test "procedure error"
410        `(methodResponse
411          (fault
412           (value (struct
413                   (member
414                    (name "faultCode")
415                    (value (i4 "-1")))
416                   (member
417                    (name "faultString")
418                    (value (string "Error in procedure")))))))
419        (xml-rpc-call->xml-rpc-response
420         `(*TOP*
421           (*PI* xml "version=\"1.0\"")
422           (methodCall
423            (methodName "scheme.List")
424            (params
425             (param (value (int "1")))
426             (param (value (int "2")))
427             (param (value (int "3"))))))
428         `((scheme.List . ,(lambda _ (error "Error in procedure")))))))
429
430(define handler (make-xml-rpc-request-handler `((scheme.List . ,list))))
431
432(test-group "request handling"
433  (call-with-input-string "doesn't matter"
434    (lambda (in)
435      (let* ((resp #f)
436             (out (call-with-output-string
437                    (lambda (out)
438                      (set! resp
439                            (handler
440                             (make-request port: in method: 'GET)
441                             (make-response port: out)))))))
442        (test 405 (response-code resp)))))
443  (call-with-input-string "invalid XML"
444    (lambda (in)
445      (let* ((resp #f)
446             (out (call-with-output-string
447                    (lambda (out)
448                      (set! resp
449                            (handler
450                             (make-request port: in method: 'POST)
451                             (make-response port: out)))))))
452        (test 200 (response-code resp))
453        (test "Invalid XML"
454              `(*TOP*
455                (*PI* xml "version=\"1.0\"")
456                (methodResponse
457                 (fault
458                  (value
459                   (struct (member (name "faultCode")
460                                   (value (i4 "3")))
461                           (member (name "faultString")
462                                   (value (string "Invalid request XML"))))))))
463              (call-with-input-string out
464                (lambda (in)
465                  (let ((resp (read-response in)))
466                    (ssax:xml->sxml (response-port resp) '()))))))))
467  (define (sxml->string sxml)
468    (string-concatenate (flatten (sxml:sxml->xml sxml))))
469  (call-with-input-string (sxml->string `(methodCall
470                                          (methodName "scheme.List")
471                                          (params
472                                           (param (value (int "1")))
473                                           (param (value (int "2")))
474                                           (param (value (int "3"))))))
475    (lambda (in)
476      (let* ((resp #f)
477             (out (call-with-output-string
478                    (lambda (out)
479                      (set! resp
480                            (handler
481                             (make-request port: in method: 'POST)
482                             (make-response port: out)))))))
483        (test 200 (response-code resp))
484        (test "Correct response to valid request"
485              `(*TOP*
486                (*PI* xml "version=\"1.0\"")
487                (methodResponse
488                 (params
489                  (param (value (array (data (value (i4 "1"))
490                                             (value (i4 "2"))
491                                             (value (i4 "3")))))))))
492              (call-with-input-string out
493                (lambda (in)
494                  (let ((resp (read-response in)))
495                    (ssax:xml->sxml (response-port resp) '())))))))))
Note: See TracBrowser for help on using the repository browser.