source: project/release/4/xml-rpc/trunk/xml-rpc-client.scm @ 15214

Last change on this file since 15214 was 15214, checked in by sjamaan, 11 years ago

Implement new, properly tested, version of xml-rpc based on http-client and sxpath. TODO: documentation and xml-rpc-server module

File size: 4.4 KB
Line 
1;;;; xml-rpc-client.scm
2;
3;; An implementation of the XML-RPC protocol
4;;
5;; This file contains a client 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-client
42  (xml-rpc-server xml-rpc-response->values)
43
44(import chicken scheme)
45(use srfi-13 data-structures http-client uri-common intarweb
46     xml-rpc-lolevel ssax sxpath-lolevel)
47
48(define (xml-rpc-response->values response-sxml)
49  (let* ((resp ((select-first-kid (ntype?? 'methodResponse)) response-sxml)))
50    (cond
51     (((select-first-kid (ntype?? 'fault)) resp) =>
52      (lambda (fault)
53        ;; Ensure the unparsing of the fault is handled so we can understand
54        ;; the result value.
55        (parameterize ((xml-rpc-parsers `((i4 . ,xml-rpc-int->number)
56                                          (int . ,xml-rpc-int->number)
57                                          (struct . ,xml-rpc-struct->alist)
58                                          (string . ,xml-rpc-string->string))))
59          (let ((val (xml-rpc-fragment->value
60                      (car ((node-join (select-first-kid (ntype?? 'value))
61                                       sxml:content)
62                            fault)))))
63            (signal-xml-rpc-error (alist-ref 'faultCode val)
64                                  (alist-ref 'faultString val))))))
65     (((select-first-kid (ntype?? 'params)) resp) =>
66      (lambda (params)
67        (apply values
68               (map
69                xml-rpc-fragment->value
70                ((node-join
71                  (select-kids (ntype?? 'param))
72                  (select-first-kid (ntype?? 'value))
73                  sxml:content)
74                 params)))))
75     (else (signal-xml-rpc-error 0 "Malformed response data" resp)))))
76
77;; Unfortunately, we need this; spec says "Content-Length" header is required
78(define (sxml->string sxml)
79  (string-concatenate (flatten (sxml:sxml->xml sxml))))
80
81(define (xml-rpc-server uri)
82  (set! uri (uri-reference uri))
83  (lambda (method-name)
84    (lambda args
85      (let* ((xml
86              (string-append
87               "<?xml version=\"1.0\"?>\n"
88               (sxml->string
89                (if (null? args)
90                    `(methodCall (methodName ,method-name))
91                    `(methodCall
92                      (methodName ,method-name)
93                      (params
94                       ,(map (lambda (p)
95                               `(param
96                                 (value ,(value->xml-rpc-fragment p))))
97                             args)))))))
98             (req (make-request
99                   method: 'POST uri: uri
100                   headers: (headers `((content-length ,(string-length xml)))))))
101        (xml-rpc-response->values
102         (call-with-input-request
103          req
104          (lambda (p) (display xml p))
105          (lambda (p) (ssax:xml->sxml p '()))))))))
106
107)
Note: See TracBrowser for help on using the repository browser.