summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsjamaan <>2009-07-15 19:26:05 +0000
committersjamaan <>2009-07-15 19:26:05 +0000
commitc6f5bc683cea9e5d26258f8e86693a4bcb72ed91 (patch)
treed8c7e1294dfb4a83343dc7f543874b21896205c2
parentca5ace315f7c7157bc86a2864e5fbd132e82b614 (diff)
downloadchicken-xml-rpc-c6f5bc683cea9e5d26258f8e86693a4bcb72ed91.tar
chicken-xml-rpc-c6f5bc683cea9e5d26258f8e86693a4bcb72ed91.tar.gz
chicken-xml-rpc-c6f5bc683cea9e5d26258f8e86693a4bcb72ed91.tar.bz2
chicken-xml-rpc-c6f5bc683cea9e5d26258f8e86693a4bcb72ed91.tar.lz
chicken-xml-rpc-c6f5bc683cea9e5d26258f8e86693a4bcb72ed91.tar.xz
chicken-xml-rpc-c6f5bc683cea9e5d26258f8e86693a4bcb72ed91.tar.zst
chicken-xml-rpc-c6f5bc683cea9e5d26258f8e86693a4bcb72ed91.zip
Import basic server code - no real infrastructure for handling POSTS yet. The code now assumes we have everything in SXML form
-rw-r--r--tests/run.scm131
-rw-r--r--xml-rpc-client.scm2
-rw-r--r--xml-rpc-server.scm85
3 files changed, 213 insertions, 5 deletions
diff --git a/tests/run.scm b/tests/run.scm
index 279a3ca..3d747cf 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -2,7 +2,11 @@
;; Should use numbers, but that's a whole new can of worms...
(load "../xml-rpc-lolevel")
+(load "../xml-rpc-client")
+(load "../xml-rpc-server")
(import xml-rpc-lolevel)
+(import xml-rpc-client)
+(import xml-rpc-server)
(test-group "Marshaling"
(test "integer"
@@ -261,9 +265,6 @@
(xml-rpc-fragment->value
`(dateTime.iso8601 "19980717T14:08:55"))))
-(load "../xml-rpc-client")
-(import xml-rpc-client)
-
(test-group "response handling"
(test "simple response"
'("test")
@@ -302,4 +303,126 @@
(member
(name "faultString")
(value (string "there was an error")))))))))
- params))) \ No newline at end of file
+ params)))
+
+(test-group "request handling"
+ (test "simple request"
+ '(1 2 3)
+ (call-xml-rpc-proc
+ `(*TOP*
+ (*PI* xml "version=\"1.0\"")
+ (methodCall
+ (methodName "scheme.List")
+ (params
+ (param (value (int "1")))
+ (param (value (int "2")))
+ (param (value (int "3"))))))
+ `((scheme.List . ,list))))
+ (test "empty params"
+ '1
+ (call-xml-rpc-proc
+ `(*TOP*
+ (*PI* xml "version=\"1.0\"")
+ (methodCall
+ (methodName "always-one")
+ (params)))
+ `((always-one . ,(constantly 1)))))
+ (test-error "unknown method"
+ (call-xml-rpc-proc
+ `(*TOP*
+ (*PI* xml "version=\"1.0\"")
+ (methodCall
+ (methodName "scheme.unknown")
+ (params
+ (param (value (int "1")))
+ (param (value (int "2")))
+ (param (value (int "3"))))))
+ `((scheme.List . ,list))))
+ (test-error "malformed request error"
+ (call-xml-rpc-proc
+ `(*TOP*
+ (*PI* xml "version=\"1.0\"")
+ (methodCall
+ (params
+ (param (value (int "1")))
+ (param (value (int "2")))
+ (param (value (int "3"))))))
+ `((scheme.List . ,list)))))
+
+(test-group "request to xml conversion"
+ (test "simple request"
+ `(methodResponse
+ (params
+ (param (value (array (data (value (i4 "1"))
+ (value (i4 "2"))
+ (value (i4 "3"))))))))
+ (xml-rpc-call->xml-rpc-response
+ `(*TOP*
+ (*PI* xml "version=\"1.0\"")
+ (methodCall
+ (methodName "scheme.List")
+ (params
+ (param (value (int "1")))
+ (param (value (int "2")))
+ (param (value (int "3"))))))
+ `((scheme.List . ,list))))
+ (test "unknown procedure"
+ `(methodResponse
+ (fault
+ (value (struct
+ (member
+ (name "faultCode")
+ (value (i4 "1")))
+ (member
+ (name "faultString")
+ (value (string "Unknown procedure \"doesnotexist\"")))))))
+ (xml-rpc-call->xml-rpc-response
+ `(*TOP*
+ (*PI* xml "version=\"1.0\"")
+ (methodCall
+ (methodName "doesnotexist")
+ (params
+ (param (value (int "1")))
+ (param (value (int "2")))
+ (param (value (int "3"))))))
+ `((scheme.List . ,list))))
+ (test "malformed request"
+ `(methodResponse
+ (fault
+ (value (struct
+ (member
+ (name "faultCode")
+ (value (i4 "2")))
+ (member
+ (name "faultString")
+ (value (string "Bad request XML")))))))
+ (xml-rpc-call->xml-rpc-response
+ `(*TOP*
+ (*PI* xml "version=\"1.0\"")
+ (somethingFubar
+ (methodName "scheme.List")
+ (params
+ (param (value (int "1")))
+ (param (value (int "2")))
+ (param (value (int "3"))))))
+ `((scheme.List . ,list))))
+ (test "procedure error"
+ `(methodResponse
+ (fault
+ (value (struct
+ (member
+ (name "faultCode")
+ (value (i4 "-1")))
+ (member
+ (name "faultString")
+ (value (string "Error in procedure")))))))
+ (xml-rpc-call->xml-rpc-response
+ `(*TOP*
+ (*PI* xml "version=\"1.0\"")
+ (methodCall
+ (methodName "scheme.List")
+ (params
+ (param (value (int "1")))
+ (param (value (int "2")))
+ (param (value (int "3"))))))
+ `((scheme.List . ,(lambda _ (error "Error in procedure"))))))) \ No newline at end of file
diff --git a/xml-rpc-client.scm b/xml-rpc-client.scm
index eb4bdec..9f37108 100644
--- a/xml-rpc-client.scm
+++ b/xml-rpc-client.scm
@@ -72,7 +72,7 @@
(select-first-kid (ntype?? 'value))
sxml:content)
params)))))
- (else (signal-xml-rpc-error 0 "Malformed response data" resp)))))
+ (else (signal-xml-rpc-error 0 "Malformed response data" response-sxml)))))
;; Unfortunately, we need this; spec says "Content-Length" header is required
(define (sxml->string sxml)
diff --git a/xml-rpc-server.scm b/xml-rpc-server.scm
new file mode 100644
index 0000000..3471376
--- /dev/null
+++ b/xml-rpc-server.scm
@@ -0,0 +1,85 @@
+;;;; xml-rpc-server.scm
+;
+;; An implementation of the XML-RPC protocol
+;;
+;; This file contains a server implementation.
+;
+; Copyright (c) 2009, Peter Bex
+; Parts Copyright (c) Felix Winkelmann
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1. Redistributions of source code must retain the above copyright
+; notice, this list of conditions and the following disclaimer.
+; 2. Redistributions in binary form must reproduce the above copyright
+; notice, this list of conditions and the following disclaimer in the
+; documentation and/or other materials provided with the distribution.
+; 3. Neither the name of the author nor the names of its
+; contributors may be used to endorse or promote products derived
+; from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+; OF THE POSSIBILITY OF SUCH DAMAGE.
+;
+; Please report bugs, suggestions and ideas to the Chicken Trac
+; ticket tracking system (assign tickets to user 'sjamaan'):
+; http://trac.callcc.org
+
+(module xml-rpc-server
+ (call-xml-rpc-proc xml-rpc-call->xml-rpc-response)
+
+(import chicken scheme)
+(use extras data-structures xml-rpc-lolevel sxpath-lolevel)
+
+(define (call-xml-rpc-proc call-sxml procedures)
+ (or (and-let* ((call ((select-first-kid (ntype?? 'methodCall)) call-sxml))
+ (method ((select-first-kid (ntype?? 'methodName)) call))
+ (method-name (string->symbol (sxml:text method)))
+ (args ((node-join
+ (select-first-kid (ntype?? 'params))
+ (select-kids (ntype?? 'param))
+ (select-first-kid (ntype?? 'value))
+ sxml:content)
+ call)))
+ (cond
+ ((alist-ref method-name procedures) =>
+ (lambda (proc)
+ (apply proc (map xml-rpc-fragment->value args))))
+ (else (signal-xml-rpc-error
+ 1 (sprintf "Unknown procedure \"~A\"" method-name)))))
+ (signal-xml-rpc-error 2 "Bad request XML" call-sxml)))
+
+(define (xml-rpc-call->xml-rpc-response call-sxml procedures)
+ `(methodResponse
+ ,(handle-exceptions exn
+ `(fault
+ (value
+ ,(value->xml-rpc-fragment
+ `((faultCode . ,(or ((condition-property-accessor 'xml-rpc 'code)
+ exn)
+ -1))
+ (faultString . ,(or ((condition-property-accessor 'exn 'message)
+ exn)
+ "Unknown internal error"))))))
+ (call-with-values
+ (lambda () (call-xml-rpc-proc call-sxml procedures))
+ (lambda values
+ `(params
+ ,@(map (lambda (p)
+ `(param (value ,(value->xml-rpc-fragment p))))
+ values)))))))
+
+) \ No newline at end of file