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

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

Always close ports, also when an exception occurred

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