summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsjamaan <>2009-07-25 14:21:46 +0000
committersjamaan <>2009-07-25 14:21:46 +0000
commit83b53efd540fc6c62bb7a6860f8080a53e0745fa (patch)
tree27470c3ab7697cd3970b6bbe2e2c914ae349ce79
parent5b419d4551e672f7f7ba409db4b960b78248fe32 (diff)
downloadchicken-xml-rpc-83b53efd540fc6c62bb7a6860f8080a53e0745fa.tar
chicken-xml-rpc-83b53efd540fc6c62bb7a6860f8080a53e0745fa.tar.gz
chicken-xml-rpc-83b53efd540fc6c62bb7a6860f8080a53e0745fa.tar.bz2
chicken-xml-rpc-83b53efd540fc6c62bb7a6860f8080a53e0745fa.tar.lz
chicken-xml-rpc-83b53efd540fc6c62bb7a6860f8080a53e0745fa.tar.xz
chicken-xml-rpc-83b53efd540fc6c62bb7a6860f8080a53e0745fa.tar.zst
chicken-xml-rpc-83b53efd540fc6c62bb7a6860f8080a53e0745fa.zip
Implement a simple xml-rpc procedure
-rw-r--r--tests/run.scm2
-rw-r--r--xml-rpc-server.scm20
2 files changed, 19 insertions, 3 deletions
diff --git a/tests/run.scm b/tests/run.scm
index 6d45135..b50a385 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -429,7 +429,7 @@
(define handler (make-xml-rpc-request-handler `((scheme.List . ,list))))
-(test-group "Request handling"
+(test-group "request handling"
(call-with-input-string "doesn't matter"
(lambda (in)
(let* ((resp #f)
diff --git a/xml-rpc-server.scm b/xml-rpc-server.scm
index f582e11..00a824b 100644
--- a/xml-rpc-server.scm
+++ b/xml-rpc-server.scm
@@ -40,10 +40,11 @@
(module xml-rpc-server
(call-xml-rpc-proc xml-rpc-call->xml-rpc-response
- make-xml-rpc-request-handler)
+ make-xml-rpc-request-handler start-simple-xml-rpc-server)
(import chicken scheme)
-(use srfi-13 extras data-structures xml-rpc-lolevel sxpath-lolevel ssax intarweb)
+(use srfi-13 srfi-18 extras data-structures tcp
+ xml-rpc-lolevel sxpath-lolevel ssax intarweb)
(define (call-xml-rpc-proc call-sxml procedures)
(or (and-let* ((call ((select-first-kid (ntype?? 'methodCall)) call-sxml))
@@ -135,4 +136,19 @@
(display xml-string (response-port resp))
resp))))
+(define (start-simple-xml-rpc-server procedures #!optional (port 8080))
+ (let ((listener (tcp-listen port))
+ (handler (make-xml-rpc-request-handler procedures)))
+ (let accept-next-connection ()
+ (receive (in out)
+ (tcp-accept listener)
+ (thread-start!
+ (lambda ()
+ (handle-exceptions e
+ (void)
+ (let ((req (read-request in))
+ (resp (make-response port: out)))
+ (handler req resp)))))
+ (accept-next-connection)))))
+
) \ No newline at end of file