Changeset 15250 in project

Timestamp:

07/25/09 16:21:46 (12 years ago)

Author:

sjamaan

Message:

Implement a simple xml-rpc procedure

Location:

release/4/xml-rpc/trunk

Files:

• tests/run.scm (modified) (1 diff)
• xml-rpc-server.scm (modified) (2 diffs)

release/4/xml-rpc/trunk/tests/run.scm

@@ -430 +430 @@
 (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)

release/4/xml-rpc/trunk/xml-rpc-server.scm

@@ -41 +41 @@
 (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)
@@ -136 +137 @@
           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)))))
+
 )