1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
|
(*
* XmlRpc Light, a small XmlRpc library based on Xml Light and Ocamlnet
* Copyright (C) 2007-2009 Dave Benjamin (dave@ramenlabs.com)
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
type param_type =
[ `Array
| `Binary
| `Boolean
| `DateTime
| `Double
| `Int
| `String
| `Struct
| `Undefined ]
let invalid_method name =
raise
(XmlRpc.Error
(-32601, "server error. requested method " ^ name ^ " not found"))
let invalid_params () =
raise
(XmlRpc.Error
(-32602, "server error. invalid method parameters"))
let wrong_num_params () =
raise
(XmlRpc.Error
(-32602, "server error. wrong number of method parameters"))
let system_get_capabilities introspection _ =
let capabilities =
[
"system.multicall",
`Struct
[
"specUrl", `String "http://www.xmlrpc.com/discuss/msgReader$1208";
"specVersion", `Int 1;
];
"xmlrpc",
`Struct
[
"specUrl", `String "http://www.xmlrpc.com/spec";
"specVersion", `Int 1;
];
"faults_interop",
`Struct
[
"specUrl", `String "http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php";
"specVersion", `Int 20010516;
];
"nil",
`Struct
[
"specUrl", `String "http://www.ontosys.com/xml-rpc/extensions.php";
"specVersion", `Int 20010518;
];
] in
let capabilities =
if introspection
then capabilities @
[
"introspection",
`Struct
[
"specUrl", `String "http://xmlrpc.usefulinc.com/doc/reserved.html";
"specVersion", `Int 1
]
]
else capabilities in
`Struct capabilities
let system_list_methods methods _ =
let names = ref [] in
Hashtbl.iter
(fun n _ -> names := `String n :: !names)
methods;
`Array (List.sort compare !names)
let system_method_help method_help = function
| [`String name] ->
(try `String (Hashtbl.find method_help name)
with Not_found -> invalid_method name)
| _ -> invalid_params ()
let system_method_signature method_signatures = function
| [`String name] ->
(try `Array (List.map
(fun signature ->
`Array
(List.map
(function
| `Array -> `String "array"
| `Binary -> `String "base64"
| `Boolean -> `String "boolean"
| `DateTime -> `String "dateTime.iso8601"
| `Double -> `String "double"
| `Int -> `String "int"
| `String -> `String "string"
| `Struct -> `String "struct"
| `Undefined -> `String "undefined")
signature))
(Hashtbl.find method_signatures name))
with Not_found -> invalid_method name)
| _ -> invalid_params ()
let system_multicall methods = function
| [`Array calls] ->
`Array
(List.map
(function
| `Struct ["methodName", `String name;
"params", `Array params]
| `Struct ["params", `Array params;
"methodName", `String name] ->
(try `Array [(try Hashtbl.find methods name
with Not_found -> invalid_method name)
params]
with
| XmlRpc.Error (code, string) ->
`Struct ["faultCode", `Int code;
"faultString", `String string]
| e ->
`Struct ["faultCode", `Int (-32500);
"faultString",
`String
("application error. "
^ Printexc.to_string e)])
| _ -> invalid_params ())
calls)
| _ -> invalid_params ()
let check_signatures signatures f params =
let num_params = List.length params in
let valid_num_params signature =
List.length signature - 1 = num_params in
let valid_params signature =
let passed = ref true in
begin
match signature with
| [] -> ()
| _ :: param_types ->
List.iter2
(fun expected actual ->
match (expected, actual) with
| (`Array, `Array _)
| (`Binary, `Binary _)
| (`Boolean, `Boolean _)
| (`DateTime, `DateTime _)
| (`Double, `Double _)
| (`Int, `Int _)
| (`Int, `Int32 _)
| (`String, `String _)
| (`Struct, `Struct _)
| (`Undefined, _)
| (_, `Nil)
-> ()
| _ -> passed := false)
param_types
params
end;
!passed in
if signatures = []
then ()
else if not (List.exists valid_num_params signatures)
then wrong_num_params ()
else if not (List.exists valid_params signatures)
then invalid_params ();
f params
let rec parse_version ver =
try let i = String.index ver '.' in
int_of_string (String.sub ver 0 i) ::
parse_version (String.sub ver (i + 1) (String.length ver - i - 1))
with Not_found -> [int_of_string ver]
let ocamlnet_version = parse_version Netconst.ocamlnet_version
class virtual base =
object (self)
val methods =
(Hashtbl.create 0 : (string, XmlRpc.value list -> XmlRpc.value) Hashtbl.t)
val method_help =
(Hashtbl.create 0 : (string, string) Hashtbl.t)
val method_signatures =
(Hashtbl.create 0 : (string, param_type list list) Hashtbl.t)
val mutable base64_encoder = fun s -> XmlRpcBase64.str_encode s
val mutable base64_decoder = fun s -> XmlRpcBase64.str_decode s
val mutable datetime_encoder = XmlRpcDateTime.to_string
val mutable datetime_decoder = XmlRpcDateTime.of_string
val mutable error_handler = XmlRpc.default_error_handler
method set_base64_encoder f = base64_encoder <- f
method set_base64_decoder f = base64_decoder <- f
method set_datetime_encoder f = datetime_encoder <- f
method set_datetime_decoder f = datetime_decoder <- f
method set_error_handler f = error_handler <- f
method serve f input =
XmlRpc.serve
~base64_encoder ~base64_decoder
~datetime_encoder ~datetime_decoder
~error_handler
f input
method serve_message f input =
XmlRpc.serve_message
~error_handler
f input
method register name ?(help="") ?(signature=[]) ?(signatures=[]) f =
if help <> ""
then (Hashtbl.replace method_help name help;
self#enable_introspection ());
let signatures =
if signature <> []
then signature :: signatures
else signatures in
if signatures <> []
then (Hashtbl.replace method_signatures name signatures;
self#enable_introspection ());
Hashtbl.replace methods name (if signatures <> []
then check_signatures signatures f
else f)
method unregister name =
Hashtbl.remove methods name;
Hashtbl.remove method_help name;
Hashtbl.remove method_signatures name
method virtual run : unit -> unit
val mutable introspection = false
method private enable_introspection () =
if not introspection
then
begin
introspection <- true;
self#register "system.getCapabilities"
~help:"Returns a struct describing the XML-RPC specifications supported by this server"
~signature:[`Struct]
(system_get_capabilities true);
self#register "system.listMethods"
~help:"Returns an array of available methods on this server"
~signature:[`Array]
(system_list_methods methods);
self#register "system.methodHelp"
~help:"Returns a documentation string for the specified method"
~signature:[`String; `String]
(system_method_help method_help);
self#register "system.methodSignature"
~help:"Returns an array describing the return type and required parameters of a method"
~signature:[`Array; `String]
(system_method_signature method_signatures);
self#register "system.multicall"
~help:"Boxcar multiple RPC calls in one request"
~signature:[`Array; `Array]
(system_multicall methods);
end
initializer
self#register "system.getCapabilities" (system_get_capabilities false);
self#register "system.listMethods" (system_list_methods methods);
self#register "system.multicall" (system_multicall methods);
end
class type server =
object
inherit base
method run : unit -> unit
end
class cgi () =
object (self)
inherit base
method private process (cgi : Netcgi.cgi) =
match cgi#request_method with
| `POST ->
let input = cgi#argument_value "BODY" in
let output =
self#serve
(fun name ->
try Hashtbl.find methods name
with Not_found -> invalid_method name)
input in
cgi#set_header ~content_type:"text/xml" ();
cgi#output#output_string "<?xml version=\"1.0\"?>\n";
cgi#output#output_string output;
cgi#output#commit_work ()
| _ ->
cgi#output#output_string
"XML-RPC server accepts POST requests only.\n";
cgi#output#commit_work ()
method run () =
let config =
{ Netcgi.default_config with
Netcgi_common.permitted_input_content_types = [ "text/xml" ]
} in
let buffered _ ch = new Netchannels.buffered_trans_channel ch in
Netcgi_cgi.run ~config ~output_type:(`Transactional buffered) self#process
end
class netplex ?(parallelizer=Netplex_mp.mp()) ?(handler="xmlrpc") () =
object (self)
inherit base
method private process env (cgi : Netcgi.cgi_activation) =
match cgi#request_method with
| `POST ->
let input = cgi#argument_value "BODY" in
let output =
self#serve
(fun name ->
try Hashtbl.find methods name
with Not_found -> invalid_method name)
input in
if ocamlnet_version < [2; 2; 8]
then env#send_output_header ()
else (cgi#set_header ~content_type:"text/xml" ();
cgi#output#output_string "<?xml version=\"1.0\"?>\n");
cgi#output#output_string output;
cgi#output#commit_work ()
| _ ->
if ocamlnet_version < [2; 2; 8]
then env#send_output_header ();
cgi#output#output_string
"XML-RPC server accepts POST requests only.\n";
cgi#output#commit_work ()
method run () =
let (opt_list, cmdline_cfg) = Netplex_main.args () in
Arg.parse
opt_list
(fun s -> raise (Arg.Bad ("Don't know what to do with: " ^ s)))
("usage: " ^ Sys.executable_name ^ " [options]");
let xmlrpc =
{ Nethttpd_services.dyn_handler = self#process;
dyn_activation =
Nethttpd_services.std_activation `Std_activation_buffered;
dyn_uri = None;
dyn_translator = (fun _ -> "");
dyn_accept_all_conditionals = false
} in
let config_cgi =
{ Netcgi.default_config with
Netcgi.permitted_input_content_types = [ "text/xml" ]
} in
let handlers = [handler, xmlrpc] in
Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
Netplex_main.startup
parallelizer
Netplex_log.logger_factories
Netplex_workload.workload_manager_factories
[ Nethttpd_plex.nethttpd_factory ~config_cgi ~handlers () ]
cmdline_cfg
end
|