File Coverage

blib/lib/JSON/RPC/Legacy/Server.pm
Criterion Covered Total %
statement 25 216 11.5
branch 2 150 1.3
condition 0 32 0.0
subroutine 10 33 30.3
pod 16 19 84.2
total 53 450 11.7


line stmt bran cond sub pod time code
1             ##############################################################################
2             # JSONRPC version 1.1
3             # http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html
4             ##############################################################################
5              
6 2     2   15850 use strict;
  2         3  
  2         53  
7 2     2   545 use JSON ();
  2         11603  
  2         44  
8 2     2   9 use Carp ();
  2         2  
  2         25  
9              
10 2     2   388 use HTTP::Request ();
  2         15341  
  2         32  
11 2     2   403 use HTTP::Response ();
  2         4490  
  2         118  
12              
13              
14             ##############################################################################
15              
16             package JSON::RPC::Legacy::Server;
17              
18             my $JSONRPC_Procedure_Able;
19              
20             BEGIN {
21 2 50   2   12 if ($] >= 5.006) {
22 2         826 require JSON::RPC::Legacy::Procedure;
23 2         115 $JSONRPC_Procedure_Able = 1;
24             }
25             }
26              
27              
28             $JSON::RPC::Legacy::Server::VERSION = '0.92';
29              
30              
31             BEGIN {
32 2     2   3 for my $method (qw/request path_info json version error_message max_length charset content_type
33             error_response_header return_die_message/)
34             {
35 20 0   0 1 4078 eval qq|
  0 0   0 1 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 50   2 1 0  
  0 0   0 1 0  
  0 0   0 1 0  
  0 0   0 1 0  
  0 0   0 1 0  
  2 0   0 1 988  
  2         10  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
36             sub $method {
37             \$_[0]->{$method} = \$_[1] if defined \$_[1];
38             \$_[0]->{$method};
39             }
40             |;
41             }
42             }
43              
44              
45             sub create_json_coder {
46 1     1 1 17 JSON->new->utf8; # assumes UTF8
47             }
48              
49              
50             sub new {
51 2     2 1 11 my $class = shift;
52              
53 2         7 bless {
54             max_length => 1024 * 100,
55             charset => 'UTF-8',
56             content_type => 'application/json',
57             json => $class->create_json_coder,
58             loaded_module => { name => {}, order => [], },
59             @_,
60             }, $class;
61             }
62              
63              
64             *dispatch_to = *dispatch; # Alias
65              
66              
67             sub dispatch {
68 0     0 1   my ($self, @arg) = @_;
69              
70 0 0         if (@arg == 0){
    0          
71 0           Carp::carp "Run test mode...";
72             }
73             elsif (@arg > 1) {
74 0           for my $pkg (@arg) {
75 0           $self->_load_module($pkg);
76             }
77             }
78             else {
79 0 0         if (ref $arg[0] eq 'ARRAY') {
    0          
    0          
80 0           for my $pkg (@{$arg[0]}) {
  0            
81 0           $self->_load_module($pkg);
82             }
83             }
84             elsif (ref $arg[0] eq 'HASH') { # Lazy loading
85 0           for my $path (keys %{$arg[0]}) {
  0            
86 0           my $pkg = $arg[0]->{$path};
87 0           $self->{dispatch_path}->{$path} = $pkg;
88             }
89             }
90             elsif (ref $arg[0]) {
91 0           Carp::croak 'Invalid dispatch value.';
92             }
93             else { # Single module
94 0           $self->_load_module($arg[0]);
95             }
96             }
97              
98 0           $self;
99             }
100              
101              
102             sub handle {
103 0     0 1   my ($self) = @_;
104 0           my ($obj, $res, $jsondata);
105              
106 0 0         if ($self->request->method eq 'POST') {
    0          
107 0           $jsondata = $self->retrieve_json_from_post();
108             }
109             elsif ($self->request->method eq 'GET') {
110 0           $jsondata = $self->retrieve_json_from_get();
111             }
112              
113 0 0         if ( $jsondata ) {
114 0           $obj = eval q| $self->json->decode($jsondata) |;
115 0 0         if ($@) {
116 0           $self->raise_error(code => 201, message => "Can't parse JSON data.");
117             }
118             }
119             else { # may have error_response_header at retroeve_json_from_post / get
120 0 0         unless ($self->error_response_header) {
121 0           $self->error_response_header($self->response_header(403, 'No data.'));
122             }
123             }
124              
125 0 0         if ($obj) {
126 0           $res = $self->_handle($obj);
127 0 0         unless ($self->error_response_header) {
128 0           return $self->response( $self->response_header(200, $res) );
129             }
130             }
131              
132 0           $self->response( $self->error_response_header );
133             }
134              
135              
136       0 1   sub retrieve_json_from_post { } # must be implemented in subclass
137              
138              
139       0 1   sub retrieve_json_from_get { } # must be implemented in subclass
140              
141              
142       0 1   sub response { } # must be implemented in subclass
143              
144              
145              
146             sub raise_error {
147 0     0 1   my ($self, %opt) = @_;
148 0   0       my $status_code = $opt{status_code} || 200;
149              
150 0 0 0       if (exists $opt{version} and $opt{version} ne '1.1') {
151 0           $self->version(0);
152             }
153             else {
154 0           $self->version(1.1);
155             }
156              
157 0           my $res = $self->_error($opt{id}, $opt{code}, $opt{message});
158              
159 0           $self->error_response_header($self->response_header($status_code, $res));
160              
161 0           return;
162             }
163              
164              
165             sub response_header {
166 0     0 0   my ($self, $code, $result) = @_;
167 0           my $h = HTTP::Headers->new;
168 0           $h->header('Content-Type' => $self->content_type . '; charset=' . $self->charset);
169 0           HTTP::Response->new($code => undef, $h, $result);
170             }
171              
172              
173             sub _handle {
174 0     0     my ($self, $obj) = @_;
175              
176 0 0         $obj->{version} ? $self->version(1.1) : $self->version(0);
177              
178 0           my $method = $obj->{method};
179              
180 0 0         if (!defined $method) {
    0          
181 0           return $self->_error($obj->{id}, 300, "method is nothing.");
182             }
183             elsif ($method =~ /[^-._a-zA-Z0-9]/) {
184 0           return $self->_error($obj->{id}, 301, "method is invalid.");
185             }
186              
187 0           my $procedure = $self->_find_procedure($method);
188              
189 0 0         unless ($procedure) {
190 0           return $self->_error($obj->{id}, 302, "No such a method : '$method'.");
191             }
192              
193 0           my $params;
194              
195 0 0         unless ($obj->{version}) {
196 0 0 0       unless ($obj->{params} and ref($obj->{params}) eq 'ARRAY') {
197 0           return $self->_error($obj->{id}, 400, "Invalid params for JSONRPC 1.0.");
198             }
199             }
200              
201 0 0         unless ($params = $self->_argument_type_check($procedure->{argument_type}, $obj->{params})) {
202 0           return $self->_error($obj->{id}, 401, $self->error_message);
203             }
204              
205 0           my $result;
206              
207 0 0         if ($obj->{version}) {
208 0 0         $result = ref $params ? eval q| $procedure->{code}->($self, $params) |
209             : eval q| $procedure->{code}->($self) |
210             ;
211             }
212             else {
213 0           my @params;
214 0 0         if(ref($params) eq 'ARRAY') {
215 0           @params = @$params;
216             }
217             else {
218 0           $params[0] = $params;
219             }
220 0           $result = eval q| $procedure->{code}->($self, @params) |;
221             }
222              
223              
224 0 0         if ($self->error_response_header) {
    0          
225 0           return;
226             }
227             elsif ($@) {
228 0 0         return $self->_error($obj->{id}, 500, ($self->return_die_message ? $@ : 'Procedure error.'));
229             }
230              
231 0 0 0       if (!$obj->{version} and !defined $obj->{id}) { # notification
232 0           return '';
233             }
234              
235 0           my $return_obj = {result => $result};
236              
237 0 0         if ($obj->{version}) {
238 0           $return_obj->{version} = '1.1';
239             }
240             else {
241 0           $return_obj->{error} = undef;
242 0           $return_obj->{id} = $obj->{id};
243             }
244              
245 0           return $self->json->encode($return_obj);
246             }
247              
248              
249             sub _find_procedure {
250 0     0     my ($self, $method) = @_;
251 0           my $found;
252             my $classname;
253 0           my $system_call;
254              
255 0 0         if ($method =~ /^system\.(\w+)$/) {
    0          
256 0           $system_call = 1;
257 0           $method = $1;
258             }
259             elsif ($method =~ /\./) {
260 0           my @p = split/\./, $method;
261 0           $method = pop @p;
262 0           $classname= join('::', @p);
263             }
264              
265 0 0         if ($self->{dispatch_path}) {
266 0           my $path = $self->{path_info};
267              
268 0 0         if (my $pkg = $self->{dispatch_path}->{$path}) {
269              
270 0 0 0       return if ( $classname and $pkg ne $classname );
271 0 0 0       return if ( $JSONRPC_Procedure_Able and JSON::RPC::Legacy::Procedure->can( $method ) );
272              
273 0           $self->_load_module($pkg);
274              
275 0 0         if ($system_call) { $pkg .= '::system' }
  0            
276              
277 0           return $self->_method_is_ebable($pkg, $method, $system_call);
278             }
279             }
280             else {
281 0           for my $pkg (@{$self->{loaded_module}->{order}}) {
  0            
282              
283 0 0 0       next if ( $classname and $pkg ne $classname );
284 0 0 0       next if ( $JSONRPC_Procedure_Able and JSON::RPC::Legacy::Procedure->can( $method ) );
285              
286 0 0         if ($system_call) { $pkg .= '::system' }
  0            
287              
288 0 0         if ( my $ret = $self->_method_is_ebable($pkg, $method, $system_call) ) {
289 0           return $ret;
290             }
291             }
292             }
293              
294 0           return;
295             }
296              
297              
298             sub _method_is_ebable {
299 0     0     my ($self, $pkg, $method, $system_call) = @_;
300              
301 0           my $allowable_procedure = $pkg->can('allowable_procedure');
302 0           my $code;
303              
304 0 0         if ( $allowable_procedure ) {
305 0 0         if ( exists $allowable_procedure->()->{ $method } ) {
306 0           $code = $allowable_procedure->()->{ $method };
307             }
308             else {
309 0           return;
310             }
311             }
312              
313 0 0 0       if ( $code or ( $code = $pkg->can($method) ) ) {
314 0 0 0       return {code => $code} if ($system_call or !$JSONRPC_Procedure_Able);
315              
316 0 0         if ( my $procedure = JSON::RPC::Legacy::Procedure::check($pkg, $code) ) {
317 0 0 0       return if ($procedure->{return_type} and $procedure->{return_type} eq 'Private');
318 0           $procedure->{code} = $code;
319 0           return $procedure;
320             }
321             }
322              
323 0 0         if ($system_call) { # if not found, default system.foobar
324 0 0         if ( my $code = 'JSON::RPC::Legacy::Server::system'->can($method) ) {
325 0           return {code => $code};
326             }
327             }
328              
329 0           return;
330             }
331              
332              
333             sub _argument_type_check {
334 0     0     my ($self, $type, $params) = @_;
335              
336 0 0         unless (defined $type) {
337 0 0         return defined $params ? $params : 1;
338             }
339              
340 0           my $regulated;
341              
342 0 0         if (ref $params eq 'ARRAY') {
    0          
    0          
343 0 0         if (@{$type->{position}} != @$params) {
  0            
344 0           $self->error_message("Number of params is mismatch.");
345 0           return;
346             }
347              
348 0 0         if (my $hash = $type->{names}) {
349 0           my $i = 0;
350 0           for my $name (keys %$hash) {
351 0           $regulated->{$name} = $params->[$i++];
352             }
353             }
354              
355             }
356             elsif (ref $params eq 'HASH') {
357 0 0         if (@{$type->{position}} != keys %$params) {
  0            
358 0           $self->error_message("Number of params is mismatch.");
359 0           return;
360             }
361              
362 0 0         if (my $hash = $type->{names}) {
363 0           my $i = 0;
364 0           for my $name (keys %$params) {
365 0 0         if ($name =~ /^\d+$/) {
366 0           my $realname = $type->{position}[$name];
367 0           $regulated->{$realname} = $params->{$name};
368             }
369             else {
370 0           $regulated->{$name} = $params->{$name};
371             }
372             }
373             }
374              
375             }
376             elsif (!defined $params) {
377 0 0         if (@{$type->{position}} != 0) {
  0            
378 0           $self->error_message("Number of params is mismatch.");
379 0           return;
380             }
381 0           return 1;
382             }
383             else {
384 0           $self->error_message("the params member is any other type except JSON Object or Array.");
385 0           return;
386             }
387              
388 0 0         return $regulated ? $regulated : $params;
389             }
390              
391              
392             sub _load_module {
393 0     0     my ($self, $pkg) = @_;
394              
395 0           eval qq| require $pkg |;
396              
397 0 0         if ($@) {
398 0           Carp::croak $@;
399             }
400              
401 0           $self->{loaded_module}->{name}->{$pkg} = $pkg;
402 0           push @{ $self->{loaded_module}->{order} }, $pkg;
  0            
403             }
404              
405              
406             # Error Handling
407              
408             sub _error {
409 0     0     my ($self, $id, $code, $message) = @_;
410              
411 0 0         if ($self->can('translate_error_message')) {
412 0           $message = $self->translate_error_message($code, $message);
413             }
414              
415 0           my $error_obj = {
416             name => 'JSONRPCError',
417             code => $code,
418             message => $message,
419             };
420              
421 0           my $obj;
422              
423 0 0         if ($self->version) {
424 0           $obj = {
425             version => "1.1",
426             error => $error_obj,
427             };
428 0 0         $obj->{id} = $id if (defined $id);
429             }
430             else {
431 0 0         return '' if (!defined $id);
432 0           $obj = {
433             result => undef,
434             error => $message,
435             id => $id,
436             };
437             }
438              
439 0           return $self->json->encode($obj);
440             }
441              
442              
443             ##############################################################################
444              
445             package JSON::RPC::Legacy::Server::system;
446              
447             sub describe {
448             {
449 0     0     sdversion => "1.0",
450             name => __PACKAGE__,
451             summary => 'Default system description',
452             }
453             }
454              
455              
456             1;
457             __END__