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

Last change on this file since 15249 was 15249, checked in by sjamaan, 10 years ago

Implement request/response handler

File size: 5.9 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   make-xml-rpc-request-handler)
44
45(import chicken scheme)
46(use srfi-13 extras data-structures xml-rpc-lolevel sxpath-lolevel ssax intarweb)
47
48(define (call-xml-rpc-proc call-sxml procedures)
49  (or (and-let* ((call ((select-first-kid (ntype?? 'methodCall)) call-sxml))
50                 (method ((select-first-kid (ntype?? 'methodName)) call))
51                 (method-name (string->symbol (sxml:text method)))
52                 (args ((node-join
53                         (select-first-kid (ntype?? 'params))
54                         (select-kids (ntype?? 'param))
55                         (select-first-kid (ntype?? 'value))
56                         sxml:content)
57                        call)))
58        (cond
59         ((alist-ref method-name procedures) =>
60          (lambda (proc)
61            (apply proc (map xml-rpc-fragment->value args))))
62         (else (signal-xml-rpc-error
63                1 (sprintf "Unknown procedure \"~A\"" method-name)))))
64      (signal-xml-rpc-error 2 "Bad request XML" call-sxml)))
65
66(define (xml-rpc-call->xml-rpc-response call-sxml procedures)
67  `(methodResponse
68    ,(handle-exceptions exn
69       `(fault
70         (value
71          ,(value->xml-rpc-fragment
72            `((faultCode . ,(or ((condition-property-accessor 'xml-rpc 'code)
73                                 exn)
74                                -1))
75              (faultString . ,(or ((condition-property-accessor 'exn 'message)
76                                   exn)
77                                  "Unknown internal error"))))))
78       (call-with-values
79           (lambda () (call-xml-rpc-proc call-sxml procedures))
80         (lambda values
81           `(params
82             ,@(map (lambda (p)
83                      `(param (value ,(value->xml-rpc-fragment p))))
84                    values)))))))
85
86;; Unfortunately, we need this; spec says "Content-Length" header is required
87(define (sxml->string sxml)
88  (string-concatenate (flatten (sxml:sxml->xml sxml))))
89
90(define (read-request-data request)
91  (let ((len (header-value 'content-length (request-headers request))))
92    ;; If the header is not available, this will read until EOF
93    (read-string len (request-port request))))
94
95(define (make-xml-rpc-request-handler procedures)
96  (lambda (req resp)
97    (if (not (eq? (request-method req) 'POST))
98        (let* ((err "XML-RPC requests must use the POST method!\n")
99               (_ (read-request-data req))
100               (resp (write-response
101                      (update-response
102                       resp
103                       code: 405 message: "Method not allowed"
104                       headers: (headers
105                                 `((allow POST)
106                                   (content-type text/plain)
107                                   (content-length ,(string-length err)))
108                                 (response-headers resp))))))
109          (unless (eq? (request-method req) 'HEAD)
110            (display err (response-port resp)))
111          resp)
112        (let* ((sxml-response
113                 (handle-exceptions exn
114                   `(methodResponse
115                     (fault
116                      (value (struct
117                              (member (name "faultCode")
118                                      (value (i4 "3")))
119                              (member (name "faultString")
120                                      (value (string "Invalid request XML")))))))
121                   (xml-rpc-call->xml-rpc-response
122                    (ssax:xml->sxml (request-port req) '())
123                    procedures)))
124               (xml-string (string-append
125                            "<?xml version=\"1.0\"?>\n"
126                            (sxml->string sxml-response)))
127               (resp (write-response
128                      (update-response
129                       resp
130                       headers:
131                       (headers
132                        `((content-type text/xml)
133                          (content-length ,(string-length xml-string)))
134                        (response-headers resp))))))
135          (display xml-string (response-port resp))
136          resp))))
137
138)
Note: See TracBrowser for help on using the repository browser.