1##############################################################################
2# JSONRPC version 1.1
3# http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html
4##############################################################################
5
6use strict;
7use JSON ();
8use Carp ();
9
10use HTTP::Request ();
11use HTTP::Response ();
12
13
14##############################################################################
15
16package JSON::RPC::Legacy::Server;
17
18my $JSONRPC_Procedure_Able;
19
20BEGIN {
21    if ($] >= 5.006) {
22        require  JSON::RPC::Legacy::Procedure;
23        $JSONRPC_Procedure_Able = 1;
24    }
25}
26
27
28$JSON::RPC::Legacy::Server::VERSION = '0.92';
29
30
31BEGIN {
32    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        eval qq|
36            sub $method {
37                \$_[0]->{$method} = \$_[1] if defined \$_[1];
38                \$_[0]->{$method};
39            }
40        |;
41    }
42}
43
44
45sub create_json_coder {
46    JSON->new->utf8; # assumes UTF8
47}
48
49
50sub new {
51    my $class = shift;
52
53    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
67sub dispatch {
68    my ($self, @arg) = @_;
69
70    if (@arg == 0){
71        Carp::carp "Run test mode...";
72    }
73    elsif (@arg > 1) {
74        for my $pkg (@arg) {
75            $self->_load_module($pkg);
76        }
77    }
78    else {
79        if (ref $arg[0] eq 'ARRAY') {
80            for my $pkg (@{$arg[0]}) {
81                $self->_load_module($pkg);
82            }
83        }
84        elsif (ref $arg[0] eq 'HASH') { # Lazy loading
85            for my $path (keys %{$arg[0]}) {
86                my $pkg = $arg[0]->{$path};
87                $self->{dispatch_path}->{$path} = $pkg;
88            }
89        }
90        elsif (ref $arg[0]) {
91            Carp::croak 'Invalid dispatch value.';
92        }
93        else { # Single module
94            $self->_load_module($arg[0]);
95        }
96    }
97
98    $self;
99}
100
101
102sub handle {
103    my ($self) = @_;
104    my ($obj, $res, $jsondata);
105
106    if ($self->request->method eq 'POST') {
107        $jsondata = $self->retrieve_json_from_post();
108    }
109    elsif ($self->request->method eq 'GET') {
110        $jsondata = $self->retrieve_json_from_get();
111    }
112
113    if ( $jsondata ) {
114        $obj = eval q| $self->json->decode($jsondata) |;
115        if ($@) {
116            $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        unless ($self->error_response_header) {
121            $self->error_response_header($self->response_header(403, 'No data.'));
122        }
123    }
124
125    if ($obj) {
126        $res = $self->_handle($obj);
127        unless ($self->error_response_header) {
128            return $self->response( $self->response_header(200, $res) );
129        }
130    }
131
132    $self->response( $self->error_response_header );
133}
134
135
136sub retrieve_json_from_post {  }    # must be implemented in subclass
137
138
139sub retrieve_json_from_get {  }     # must be implemented in subclass
140
141
142sub response {  }                   # must be implemented in subclass
143
144
145
146sub raise_error {
147    my ($self, %opt) = @_;
148    my $status_code = $opt{status_code} || 200;
149
150    if (exists $opt{version} and $opt{version} ne '1.1') {
151        $self->version(0);
152    }
153    else {
154        $self->version(1.1);
155    }
156
157    my $res = $self->_error($opt{id}, $opt{code}, $opt{message});
158
159    $self->error_response_header($self->response_header($status_code, $res));
160
161    return;
162}
163
164
165sub response_header {
166    my ($self, $code, $result) = @_;
167    my $h = HTTP::Headers->new;
168    $h->header('Content-Type' => $self->content_type . '; charset=' . $self->charset);
169    HTTP::Response->new($code => undef, $h, $result);
170}
171
172
173sub _handle {
174    my ($self, $obj) = @_;
175
176    $obj->{version} ? $self->version(1.1) : $self->version(0);
177
178    my $method = $obj->{method};
179
180    if (!defined $method) {
181        return $self->_error($obj->{id}, 300, "method is nothing.");
182    }
183    elsif ($method =~ /[^-._a-zA-Z0-9]/) {
184        return $self->_error($obj->{id}, 301, "method is invalid.");
185    }
186
187    my $procedure = $self->_find_procedure($method);
188
189    unless ($procedure) {
190        return $self->_error($obj->{id}, 302, "No such a method : '$method'.");
191    }
192
193    my $params;
194
195    unless ($obj->{version}) {
196        unless ($obj->{params} and ref($obj->{params}) eq 'ARRAY') {
197            return $self->_error($obj->{id}, 400, "Invalid params for JSONRPC 1.0.");
198        }
199    }
200
201    unless ($params = $self->_argument_type_check($procedure->{argument_type}, $obj->{params})) {
202        return $self->_error($obj->{id}, 401, $self->error_message);
203    }
204
205    my $result;
206
207    if ($obj->{version}) {
208        $result = ref $params ? eval q| $procedure->{code}->($self, $params) |
209                              : eval q| $procedure->{code}->($self) |
210                              ;
211    }
212    else {
213        my @params;
214        if(ref($params) eq 'ARRAY') {
215            @params = @$params;
216        }
217        else {
218            $params[0] = $params;
219        }
220        $result = eval q| $procedure->{code}->($self, @params) |;
221    }
222
223
224    if ($self->error_response_header) {
225        return;
226    }
227    elsif ($@) {
228        return $self->_error($obj->{id}, 500, ($self->return_die_message ? $@ : 'Procedure error.'));
229    }
230
231    if (!$obj->{version} and !defined $obj->{id}) { # notification
232        return '';
233    }
234
235    my $return_obj = {result => $result};
236
237    if ($obj->{version}) {
238        $return_obj->{version} = '1.1';
239    }
240    else {
241        $return_obj->{error} = undef;
242        $return_obj->{id}    = $obj->{id};
243    }
244
245    return $self->json->encode($return_obj);
246}
247
248
249sub _find_procedure {
250    my ($self, $method) = @_;
251    my $found;
252    my $classname;
253    my $system_call;
254
255    if ($method =~ /^system\.(\w+)$/) {
256        $system_call = 1;
257        $method = $1;
258    }
259    elsif ($method =~ /\./) {
260        my @p = split/\./, $method;
261        $method = pop @p;
262        $classname=  join('::', @p);
263    }
264
265    if ($self->{dispatch_path}) {
266        my $path = $self->{path_info};
267
268        if (my $pkg = $self->{dispatch_path}->{$path}) {
269
270            return if ( $classname and $pkg ne $classname );
271            return if ( $JSONRPC_Procedure_Able and JSON::RPC::Legacy::Procedure->can( $method ) );
272
273            $self->_load_module($pkg);
274
275            if ($system_call) { $pkg .= '::system' }
276
277            return $self->_method_is_ebable($pkg, $method, $system_call);
278        }
279    }
280    else {
281        for my $pkg (@{$self->{loaded_module}->{order}}) {
282
283            next if ( $classname and $pkg ne $classname );
284            next if ( $JSONRPC_Procedure_Able and JSON::RPC::Legacy::Procedure->can( $method ) );
285
286            if ($system_call) { $pkg .= '::system' }
287
288            if ( my $ret = $self->_method_is_ebable($pkg, $method, $system_call) ) {
289                return $ret;
290            }
291        }
292    }
293
294    return;
295}
296
297
298sub _method_is_ebable {
299    my ($self, $pkg, $method, $system_call) = @_;
300
301    my $allowable_procedure = $pkg->can('allowable_procedure');
302    my $code;
303
304    if ( $allowable_procedure ) {
305        if ( exists $allowable_procedure->()->{ $method } ) {
306            $code = $allowable_procedure->()->{ $method };
307        }
308        else {
309            return;
310        }
311    }
312
313    if ( $code or ( $code = $pkg->can($method) ) ) {
314        return {code =>  $code} if ($system_call or !$JSONRPC_Procedure_Able);
315
316        if ( my $procedure = JSON::RPC::Legacy::Procedure::check($pkg, $code) ) {
317            return if ($procedure->{return_type} and $procedure->{return_type} eq 'Private');
318            $procedure->{code} = $code;
319            return $procedure;
320        }
321    }
322
323    if ($system_call) { # if not found, default system.foobar
324        if ( my $code = 'JSON::RPC::Legacy::Server::system'->can($method) ) {
325            return {code => $code};
326        }
327    }
328
329    return;
330}
331
332
333sub _argument_type_check {
334    my ($self, $type, $params) = @_;
335
336    unless (defined $type) {
337        return defined $params ? $params : 1;
338    }
339
340    my $regulated;
341
342    if (ref $params eq 'ARRAY') {
343        if (@{$type->{position}} != @$params) {
344            $self->error_message("Number of params is mismatch.");
345            return;
346        }
347
348        if (my $hash = $type->{names}) {
349            my $i = 0;
350            for my $name (keys %$hash) {
351                $regulated->{$name} = $params->[$i++];
352            }
353        }
354
355    }
356    elsif (ref $params eq 'HASH') {
357        if (@{$type->{position}} != keys %$params) {
358            $self->error_message("Number of params is mismatch.");
359            return;
360        }
361
362        if (my $hash = $type->{names}) {
363            my $i = 0;
364            for my $name (keys %$params) {
365                if ($name =~ /^\d+$/) {
366                    my $realname = $type->{position}[$name];
367                    $regulated->{$realname} = $params->{$name};
368                }
369                else {
370                    $regulated->{$name} = $params->{$name};
371                }
372            }
373        }
374
375    }
376    elsif (!defined $params) {
377        if (@{$type->{position}} != 0) {
378            $self->error_message("Number of params is mismatch.");
379            return;
380        }
381        return 1;
382    }
383    else {
384            $self->error_message("the params member is any other type except JSON Object or Array.");
385            return;
386    }
387
388    return $regulated ? $regulated : $params;
389}
390
391
392sub _load_module {
393    my ($self, $pkg) = @_;
394
395    eval qq| require $pkg |;
396
397    if ($@) {
398        Carp::croak $@;
399    }
400
401    $self->{loaded_module}->{name}->{$pkg} = $pkg;
402    push @{ $self->{loaded_module}->{order} }, $pkg;
403}
404
405
406# Error Handling
407
408sub _error {
409    my ($self, $id, $code, $message) = @_;
410
411    if ($self->can('translate_error_message')) {
412        $message = $self->translate_error_message($code, $message);
413    }
414
415    my $error_obj = {
416        name    => 'JSONRPCError',
417        code    => $code,
418        message => $message,
419    };
420
421    my $obj;
422
423    if ($self->version) {
424        $obj = {
425            version => "1.1",
426            error   => $error_obj,
427        };
428        $obj->{id} = $id if (defined $id);
429    }
430    else {
431        return '' if (!defined $id);
432        $obj = {
433            result => undef,
434            error  => $message,
435            id     => $id,
436        };
437    }
438
439    return $self->json->encode($obj);
440}
441
442
443##############################################################################
444
445package JSON::RPC::Legacy::Server::system;
446
447sub describe {
448    {
449        sdversion => "1.0",
450        name      => __PACKAGE__,
451        summary   => 'Default system description',
452    }
453}
454
455
4561;
457__END__
458
459=pod
460
461
462=head1 NAME
463
464JSON::RPC::Server - Perl implementation of JSON-RPC sever
465
466=head1 SYNOPSIS
467
468
469 # CGI version
470 use JSON::RPC::Legacy::Server::CGI;
471
472 my $server = JSON::RPC::Legacy::Server::CGI->new;
473
474 $server->dispatch_to('MyApp')->handle();
475
476
477
478 # Apache version
479 # In apache conf
480
481 PerlRequire /your/path/start.pl
482 PerlModule MyApp
483
484 <Location /jsonrpc/API>
485      SetHandler perl-script
486      PerlResponseHandler JSON::RPC::Legacy::Server::Apache
487      PerlSetVar dispatch "MyApp"
488      PerlSetVar return_die_message 0
489 </Location>
490
491
492
493 # Daemon version
494 use JSON::RPC::Legacy::Server::Daemon;
495
496 JSON::RPC::Legacy::Server::Daemon->new(LocalPort => 8080);
497                          ->dispatch({'/jsonrpc/API' => 'MyApp'})
498                          ->handle();
499
500
501
502 # FastCGI version
503 use JSON::RPC::Legacy::Server::FastCGI;
504
505 my $server = JSON::RPC::Legacy::Server::FastCGI->new;
506
507    $server->dispatch_to('MyApp')->handle();
508
509
510
511=head1 DESCRIPTION
512
513Gets a client request.
514
515Parses its JSON data.
516
517Passes the server object and the object decoded from the JSON data to your procedure (method).
518
519Takes your returned value (scalar or arrayref or hashref).
520
521Sends a response.
522
523Well, you write your procedure code only.
524
525
526=head1 METHODS
527
528=over
529
530=item new
531
532Creates new JSON::RPC::Legacy::Server object.
533
534
535=item dispatch($package)
536
537=item dispatch([$package1, $package1, ...])
538
539=item dispatch({$path => $package, ...})
540
541Sets your procedure module using package name list or arrayref or hashref.
542Hashref version is used for path_info access.
543
544
545
546
547
548=item dispatch_to
549
550An alias to C<dispatch>.
551
552
553=item handle
554
555Runs server object and returns a response.
556
557
558=item raise_error(%hash)
559
560 return $server->raise_error(
561    code => 501,
562    message => "This is error in my procedure."
563 );
564
565Sets an error.
566An error code number in your procedure is an integer between 501 and 899.
567
568
569=item json
570
571Setter/Getter to json encoder/decoder object.
572The default value is L<JSON> object in the below way:
573
574 JSON->new->utf8
575
576In your procedure, changes its behaviour.
577
578 $server->json->utf8(0);
579
580The JSON coder creating method is  C<create_json_coder>.
581
582
583=item version
584
585Setter/Getter to JSON-RPC protocol version used by a client.
586If version is 1.1, returns 1.1. Otherwise returns 0.
587
588
589=item charset
590
591Setter/Getter to cahrset.
592Default is 'UTF-8'.
593
594
595=item content_type
596
597Setter/Getter to content type.
598Default is 'application/json'.
599
600
601=item return_die_message
602
603When your program dies in your procedure,
604sends a return object with errror message 'Procedure error' by default.
605
606If this option is set, uses C<die> message.
607
608
609 sub your_procedure {
610     my ($s) = @_;
611    $s->return_die_message(1);
612    die "This is test.";
613 }
614
615
616
617=item retrieve_json_from_post
618
619It is used by JSON::RPC::Legacy::Server subclass.
620
621
622=item retrieve_json_from_get
623
624In the protocol v1.1, 'GET' request method is also allowable.
625
626It is used by JSON::RPC::Legacy::Server subclass.
627
628=item response
629
630It is used by JSON::RPC::Legacy::Server subclass.
631
632=item request
633
634Returns L<HTTP::Request> object.
635
636=item path_info
637
638Returns PATH_INFO.
639
640=item max_length
641
642Returns max content-length to your application.
643
644
645=item translate_error_message
646
647Implemented in your subclass.
648Three arguments (server object, error code and error message) are passed.
649It must return a message.
650
651 sub translate_error_message {
652     my ($s, $code, $message) = @_;
653     return $translation_jp_message{$code};
654 }
655
656
657=item create_json_coder
658
659(Class method)
660Returns a JSON de/encoder in C<new>.
661You can override it to use your favorite JSON de/encode.
662
663
664=back
665
666
667=head1 RESERVED PROCEDURE
668
669When a client call a procedure (method) name 'system.foobar',
670JSON::RPC::Legacy::Server look up MyApp::system::foobar.
671
672L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html#ProcedureCall>
673
674L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html#ServiceDescription>
675
676There is JSON::RPC::Legacy::Server::system::describe for default response of 'system.describe'.
677
678
679=head1 SEE ALSO
680
681L<JSON>
682
683L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html>
684
685L<http://json-rpc.org/wiki/specification>
686
687=head1 AUTHOR
688
689Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
690
691
692=head1 COPYRIGHT AND LICENSE
693
694Copyright 2007-2008 by Makamaka Hannyaharamitu
695
696This library is free software; you can redistribute it and/or modify
697it under the same terms as Perl itself.
698
699=cut
700
701
702