Import basic server code - no real infrastructure for handling POSTS yet. The code now assumes we have everything in SXML form

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