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

Last change on this file since 15222 was 15222, checked in by sjamaan, 11 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: 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 xml-rpc-methodcall)
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" response-sxml)))))
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-methodcall method-name args)
82  (if (null? args)
83      `(methodCall (methodName ,method-name))
84      `(methodCall
85        (methodName ,method-name)
86        (params
87         ,(map (lambda (p)
88                 `(param
89                   (value ,(value->xml-rpc-fragment p))))
90               args)))))
91
92(define (xml-rpc-server uri)
93  (when (string? uri)
94    (set! uri (uri-reference uri)))
95  (lambda (method-name)
96    (lambda args
97      (let* ((xml
98              (string-append
99               "<?xml version=\"1.0\"?>\n"
100               (sxml->string (xml-rpc-methodcall method-name args))))
101             (req (make-request
102                   method: 'POST uri: uri
103                   headers: (headers `((content-length ,(string-length xml)))))))
104        (xml-rpc-response->values
105         (call-with-input-request
106          req
107          (lambda (p) (display xml p))
108          (lambda (p) (ssax:xml->sxml p '()))))))))
109
110)
Note: See TracBrowser for help on using the repository browser.