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::Server; 17 18my $JSONRPC_Procedure_Able; 19 20BEGIN { 21 if ($] >= 5.006) { 22 require JSON::RPC::Procedure; 23 $JSONRPC_Procedure_Able = 1; 24 } 25} 26 27 28$JSON::RPC::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::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::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::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::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::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::Server::CGI; 471 472 my $server = JSON::RPC::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::Server::Apache 487 PerlSetVar dispatch "MyApp" 488 PerlSetVar return_die_message 0 489 </Location> 490 491 492 493 # Daemon version 494 use JSON::RPC::Server::Daemon; 495 496 JSON::RPC::Server::Daemon->new(LocalPort => 8080); 497 ->dispatch({'/jsonrpc/API' => 'MyApp'}) 498 ->handle(); 499 500 501 502 # FastCGI version 503 use JSON::RPC::Server::FastCGI; 504 505 my $server = JSON::RPC::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::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::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::Server subclass. 627 628=item response 629 630It is used by JSON::RPC::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::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::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