source: project/release/4/xml-rpc/trunk/xml-rpc-server.scm @ 15222

Last change on this file since 15222 was 15222, checked in by sjamaan, 12 years ago

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

File size: 3.6 KB
Line 
1;;;; xml-rpc-server.scm
2;
3;; An implementation of the XML-RPC protocol
4;;
5;; This file contains a server implementation.
6;
7; Copyright (c) 2009, Peter Bex
8; Parts Copyright (c) Felix Winkelmann
9; All rights reserved.
10;
11; Redistribution and use in source and binary forms, with or without
12; modification, are permitted provided that the following conditions
13; are met:
14;
15; 1. Redistributions of source code must retain the above copyright
16;    notice, this list of conditions and the following disclaimer.
17; 2. Redistributions in binary form must reproduce the above copyright
18;    notice, this list of conditions and the following disclaimer in the
19;    documentation and/or other materials provided with the distribution.
20; 3. Neither the name of the author nor the names of its
21;    contributors may be used to endorse or promote products derived
22;    from this software without specific prior written permission.
23;
24; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
25; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
26; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
27; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
28; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
29; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
30; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
31; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
32; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
33; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
34; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
35; OF THE POSSIBILITY OF SUCH DAMAGE.
36;
37; Please report bugs, suggestions and ideas to the Chicken Trac
38; ticket tracking system (assign tickets to user 'sjamaan'):
39; http://trac.callcc.org
40
41(module xml-rpc-server
42  (call-xml-rpc-proc xml-rpc-call->xml-rpc-response)
43
44(import chicken scheme)
45(use extras data-structures xml-rpc-lolevel sxpath-lolevel)
46
47(define (call-xml-rpc-proc call-sxml procedures)
48  (or (and-let* ((call ((select-first-kid (ntype?? 'methodCall)) call-sxml))
49                 (method ((select-first-kid (ntype?? 'methodName)) call))
50                 (method-name (string->symbol (sxml:text method)))
51                 (args ((node-join
52                         (select-first-kid (ntype?? 'params))
53                         (select-kids (ntype?? 'param))
54                         (select-first-kid (ntype?? 'value))
55                         sxml:content)
56                        call)))
57        (cond
58         ((alist-ref method-name procedures) =>
59          (lambda (proc)
60            (apply proc (map xml-rpc-fragment->value args))))
61         (else (signal-xml-rpc-error
62                1 (sprintf "Unknown procedure \"~A\"" method-name)))))
63      (signal-xml-rpc-error 2 "Bad request XML" call-sxml)))
64
65(define (xml-rpc-call->xml-rpc-response call-sxml procedures)
66  `(methodResponse
67    ,(handle-exceptions exn
68       `(fault
69         (value
70          ,(value->xml-rpc-fragment
71            `((faultCode . ,(or ((condition-property-accessor 'xml-rpc 'code)
72                                 exn)
73                                -1))
74              (faultString . ,(or ((condition-property-accessor 'exn 'message)
75                                   exn)
76                                  "Unknown internal error"))))))
77       (call-with-values
78           (lambda () (call-xml-rpc-proc call-sxml procedures))
79         (lambda values
80           `(params
81             ,@(map (lambda (p)
82                      `(param (value ,(value->xml-rpc-fragment p))))
83                    values)))))))
84
85)
Note: See TracBrowser for help on using the repository browser.