summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsjamaan <>2009-07-15 17:32:16 +0000
committersjamaan <>2009-07-15 17:32:16 +0000
commitca5ace315f7c7157bc86a2864e5fbd132e82b614 (patch)
treec629f747bc5825a4042a05f08e78848af450b8cd
parent488d94d53df1ff53f632e5e1005bd0cd1e19fa54 (diff)
downloadchicken-xml-rpc-ca5ace315f7c7157bc86a2864e5fbd132e82b614.tar
chicken-xml-rpc-ca5ace315f7c7157bc86a2864e5fbd132e82b614.tar.gz
chicken-xml-rpc-ca5ace315f7c7157bc86a2864e5fbd132e82b614.tar.bz2
chicken-xml-rpc-ca5ace315f7c7157bc86a2864e5fbd132e82b614.tar.lz
chicken-xml-rpc-ca5ace315f7c7157bc86a2864e5fbd132e82b614.tar.xz
chicken-xml-rpc-ca5ace315f7c7157bc86a2864e5fbd132e82b614.tar.zst
chicken-xml-rpc-ca5ace315f7c7157bc86a2864e5fbd132e82b614.zip
Fix tests and separate out the construction of a method call
-rw-r--r--tests/run.scm6
-rw-r--r--xml-rpc-client.scm27
2 files changed, 18 insertions, 15 deletions
diff --git a/tests/run.scm b/tests/run.scm
index 5e887b9..279a3ca 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -268,7 +268,7 @@
(test "simple response"
'("test")
(receive params
- (handle-xml-rpc-response
+ (xml-rpc-response->values
`(*TOP*
(*PI* xml "version=\"1.0\"")
(methodResponse
@@ -278,7 +278,7 @@
(test "multi-param response (chicken extension)"
'("test" 1 2 3)
(receive params
- (handle-xml-rpc-response
+ (xml-rpc-response->values
`(*TOP*
(*PI* xml "version=\"1.0\"")
(methodResponse
@@ -290,7 +290,7 @@
params))
(test-error "fault code throws exception"
(receive params
- (handle-xml-rpc-response
+ (xml-rpc-response->values
`(*TOP*
(*PI* xml "version=\"1.0\"")
(methodResponse
diff --git a/xml-rpc-client.scm b/xml-rpc-client.scm
index a946b9c..eb4bdec 100644
--- a/xml-rpc-client.scm
+++ b/xml-rpc-client.scm
@@ -39,7 +39,7 @@
; http://trac.callcc.org
(module xml-rpc-client
- (xml-rpc-server xml-rpc-response->values)
+ (xml-rpc-server xml-rpc-response->values xml-rpc-methodcall)
(import chicken scheme)
(use srfi-13 data-structures http-client uri-common intarweb
@@ -78,23 +78,26 @@
(define (sxml->string sxml)
(string-concatenate (flatten (sxml:sxml->xml sxml))))
+(define (xml-rpc-methodcall method-name args)
+ (if (null? args)
+ `(methodCall (methodName ,method-name))
+ `(methodCall
+ (methodName ,method-name)
+ (params
+ ,(map (lambda (p)
+ `(param
+ (value ,(value->xml-rpc-fragment p))))
+ args)))))
+
(define (xml-rpc-server uri)
- (set! uri (uri-reference uri))
+ (when (string? uri)
+ (set! uri (uri-reference uri)))
(lambda (method-name)
(lambda args
(let* ((xml
(string-append
"<?xml version=\"1.0\"?>\n"
- (sxml->string
- (if (null? args)
- `(methodCall (methodName ,method-name))
- `(methodCall
- (methodName ,method-name)
- (params
- ,(map (lambda (p)
- `(param
- (value ,(value->xml-rpc-fragment p))))
- args)))))))
+ (sxml->string (xml-rpc-methodcall method-name args))))
(req (make-request
method: 'POST uri: uri
headers: (headers `((content-length ,(string-length xml)))))))