Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 216 lines (189 sloc) 7.784 kb
e9950d9 first commit
Kanen Flowers authored
1 ;; @module Xmlrpc-server
e2bb587 Ego commit
Kanen Flowers authored
2 ;; @author Jeff Ober <jeffober@gmail.com>, Kanen Flowers <kanendosei@gmail.com>
e9950d9 first commit
Kanen Flowers authored
3 ;; @version 1.1
4 ;; @location http://static.artfulcode.net/newlisp/xmlrpc-server.lsp
5 ;; @package http://static.artfulcode.net/newlisp/xmlrpc-server.qwerty
6 ;; @description A simple XML-RPC server (updated for newlisp 10).
7 ;; Xmlrpc-server implements a basic XML-RPC server. It requires the element,
8 ;; http, sockets, and util modules, and newlisp 10.
9 ;;
10 ;; Xmlrpc-server is able to convert data between xmlrpc and newLISP. Any uncaught
11 ;; errors that occur during the loading of a response are handled by returning a fault
12 ;; response. Fault codes are gleaned from
13 ;; @link http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php Dan&nbsp;Libby's&nbsp;specifications.
14 ;;
15 ;; The server is used by registering <handler> functions that handle requests to
16 ;; a specific path. Only one introspection function, <system.listMethods>, is included.
17 ;;
18 ;; <h4>Version history</h4>
19 ;; <b>1.1</b>
20 ;; &bull; updated for newlisp 10
21 ;; &bull; updated to use element module for faster xml serialization
22 ;;
23 ;; <b>1.0</b>
24 ;; &bull; initial release
25 ;;
26 ;; @example
27 ;; (load "xmlrpc-server.lsp")
28 ;;
29 ;; (define (get-time)
30 ;; (date (date-value)))
31 ;;
32 ;; (Xmlrpc-server:add-to-registry "myapp.getTime" get-time)
33 ;; (Xmlrpc-server:run-server 8080 "/RPC2")
34
35 (context 'Xmlrpc-server)
36
37 ;;; Error codes
38 (constant
39 'NOT-WELL-FORMED -32700
40 'INVALID-XML-RPC -32600
41 'METHOD-NOT-FOUND -3260
42 'INVALID-PARAMETERS -32602
43 'APPLICATION-ERROR -32500
44 'SERVER-ERROR -32603
45 'OTHER-ERROR -32099)
46
47 (setf error-codes
48 '((NOT-WELL-FORMED (-32700 "Parse error: XML not well formed"))
49 (INVALID-XML-RPC (-32600 "Parse error: Invalid XML-RPC"))
50 (METHOD-NOT-FOUND (-32601 "Server error: Method not found"))
51 (INVALID-PARAMETERS (-32602 "Server error: Invalid method parameters"))
52 (APPLICATION-ERROR (-32500 "Application error"))
53 (SERVER-ERROR (-32400 "Server error"))
54 (OTHER-ERROR (-32099 "An error has occurred"))))
55
56 ;;; Parsing XML-RPC into Lisp expressions
57 (define (parse-request xml , old-type-tags parsed call)
58 (setf old-type-tags (xml-type-tags))
59 (xml-type-tags nil nil nil nil)
60 (setf parsed (xml-parse xml (+ 1 2 4 8)))
61 (apply xml-type-tags old-tags)
62
63 (when (or (xml-error) (not (assoc 'methodCall parsed)))
64 (throw-error (if (xml-error) NOT-WELL-FORMED INVALID-XML-RPC)))
65
66 (setf call (rest (assoc 'methodCall parsed)))
67 (list (lookup 'methodName call)
68 (map xmlrpc->lisp (rest (assoc 'params call)))))
69
70 (define (xmlrpc-value->lisp value (type-param string))
71 (case type-param
72 (string (XML:decode (string value)))
73 (i4 (int value 0 10))
74 (int (int value 0 10))
75 (double (float value))
76 (boolean (= "1" value))
77 (base64 (base64-dec value))
78 (true (XML:decode (string value)))))
79
80 (define (xmlrpc->lisp expr , m)
81 (cond
82 ((setf m (match '(param (value (? ?))) expr))
83 (xmlrpc-value->lisp (m 1) (m 0)))
84 ((setf m (match '(param (value ?)) expr))
85 (xmlrpc-value->lisp (m 0)))
86 ((setf m (match '(param (array (data *))) expr))
87 (map 'xmlrpc->lisp (map list (dup 'param (length (m 0))) (m 0))))
88 ((setf m (match '(param (struct *)) expr))
89 (map (fn (x)
90 (list (lookup 'name x)
91 (xmlrpc->lisp (list 'param (assoc (x 'value))))))
92 (m 0)))
93 (true (string "???: " expr))))
94
95 ;;; Generating XML-RPC from Lisp expressions
96 (define (array->xmlrpc e)
97 (list->xmlrpc (array-list e)))
98
99 (define (list->xmlrpc e)
100 (Element "array" nil
101 (Element "data" nil
102 (join (map lisp->value e)))))
103
104 (define (context->xmlrpc e)
105 (Element "struct" nil
106 (map (fn (key)
107 (Element "member" nil
108 (Element "name" nil key)
109 (lisp->value (e key))))
110 (keys e))))
111
112 (define (lisp->value expr)
113 (case (type-of expr)
114 ("integer" (Element "value" nil (Element "int" nil expr)))
115 ("float" (Element "value" nil (Element "double" nil expr)))
116 ("boolean" (Element "value" nil (Element "boolean" nil (if (true? expr) 1 0))))
117 ("array" (Element "value" nil (array->xmlrpc expr)))
118 ("list" (Element "value" nil (list->xmlrpc expr)))
119 ("context" (Element "value" nil (context->xmlrpc expr)))
120 ("symbol" (Element "value" nil (Element "string" nil (Element:encode (name expr)))))
121 (true (Element "value" nil (Element "string" nil (Element:encode expr))))))
122
123 (define (lisp->xmlrpc-params expr)
124 (Element "params" nil
125 (if (atom? expr)
126 (Element "param" nil (lisp->value expr))
127 (apply 'string (map (fn (v) (Element "param" nil v))
128 (map lisp->value expr))))))
129
130 (define (response str)
131 (Element:doc nil (Element "methodResponse" nil str)))
132
133 ;;; Faults
134 (define (fault code msg)
135 (if-not msg (setf msg (or (lookup code error-codes) "Unknown error")))
136 (response
137 (Element "fault" nil
138 (Element "value" nil
139 (Element "struct" nil
140 (Element "member" nil
141 (Element "name" nil "faultCode")
142 (Element "value" nil (Element "int" nil code)))
143 (Element "member" nil
144 (Element "name" nil "faultString")
145 (Element "value" nil (Element "string" nil (Element:encode msg)))))))))
146
147 ;;; Registration of functions
148
149 ;; @syntax (Xmlrpc-server:add-to-registry <str-path> <lambda-func>)
150 ;; @param <str-path> the path which will respond to the passed function
151 ;; @param <lambda-func> the function which will be applied to requests on <str-path>
152 ;; <p>Registers a function to respond when requests are sent to <str-path>. The function
153 ;; will be passed a lisp representation of the XML-RPC request.</p>
154 (setf registry '())
155
156 (define (add-to-registry key func)
157 (push (list (string key) func) registry -1))
158
159 (define (registered key)
160 (lookup key registry))
161
162 ;;; Xmlrpc response handler
163 (define (response-handler request-xml , req fun res)
164 (if-not (catch (parse-request request-xml) 'req)
165 ;; parse error
166 (fault req)
167 ;; valid xml-rpc
168 (if-not (setf fun (registered (first req)))
169 ;; method not found
170 (fault METHOD-NOT-FOUND (string "Method not found: " (first req)))
171 ;; valid method
172 (if-not (catch (apply fun (req 1)) 'res)
173 ;; error in function
174 (fault APPLICATION-ERROR (string "Application error: " (first (parse res "\n"))))
175 ;; valid response
176 (if-not (catch (lisp->xmlrpc-params res) 'res)
177 ;; server error when translating to xmlrpc params
178 (fault SERVER-ERROR res)
179 ;; valid response
180 (response res))))))
181
182 (define (handler request , http res)
183 (if (catch
184 (begin
185 (setf http (Http:parse-request request))
186 (when (and (= "POST" (upper-case (lookup "method" http)))
187 (= server-path (trim (lookup "path" http) "" "/")))
188 (let ((resp (response-handler (lookup "content" http))))
189 (Http:format-response resp 200 "text/xml"))))
190 'res)
191 res
192 (Http:format-response
193 (fault SERVER-ERROR (string "Server error: " res))
194 200 "text/xml")))
195
196 ;; @syntax (Xmlrpc-server:run-server [<int-port> [<str-path>]])
197 ;; @param <int-port> port on which to listen; defaults to 8080
198 ;; @param <str-path> path on which to response; defaults to "/RPC2"
199 ;; <p>Initializes and starts server. Server will block if-not started in a
200 ;; child process.</p>
201 (setf server-path "/RPC2")
202
203 (define (run-server (port 8080) (path "/RPC2"))
204 (setf server-path path)
205 (setf SocketServer:handler handler)
206 (println "Starting server")
207 (SocketServer:serve port))
208
209 ;;; Introspection methods (partially implemented)
210 (define (system-listMethods)
211 (list (map 'string (map 'first registry))))
212
213 (add-to-registry "system.listMethods" system-listMethods)
214
215 (context MAIN)
Something went wrong with that request. Please try again.