##############################################################################
# JSONRPC version 1.1
# http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html
##############################################################################
use strict;
use JSON ();
use Carp ();
use HTTP::Request ();
use HTTP::Response ();
##############################################################################
package JSON::RPC::Legacy::Server;
my $JSONRPC_Procedure_Able;
BEGIN {
if ($] >= 5.006) {
require JSON::RPC::Legacy::Procedure;
$JSONRPC_Procedure_Able = 1;
}
}
$JSON::RPC::Legacy::Server::VERSION = '0.92';
BEGIN {
for my $method (qw/request path_info json version error_message max_length charset content_type
error_response_header return_die_message/)
{
eval qq|
sub $method {
\$_[0]->{$method} = \$_[1] if defined \$_[1];
\$_[0]->{$method};
}
|;
}
}
sub create_json_coder {
JSON->new->utf8; # assumes UTF8
}
sub new {
my $class = shift;
bless {
max_length => 1024 * 100,
charset => 'UTF-8',
content_type => 'application/json',
json => $class->create_json_coder,
loaded_module => { name => {}, order => [], },
@_,
}, $class;
}
*dispatch_to = *dispatch; # Alias
sub dispatch {
my ($self, @arg) = @_;
if (@arg == 0){
Carp::carp "Run test mode...";
}
elsif (@arg > 1) {
for my $pkg (@arg) {
$self->_load_module($pkg);
}
}
else {
if (ref $arg[0] eq 'ARRAY') {
for my $pkg (@{$arg[0]}) {
$self->_load_module($pkg);
}
}
elsif (ref $arg[0] eq 'HASH') { # Lazy loading
for my $path (keys %{$arg[0]}) {
my $pkg = $arg[0]->{$path};
$self->{dispatch_path}->{$path} = $pkg;
}
}
elsif (ref $arg[0]) {
Carp::croak 'Invalid dispatch value.';
}
else { # Single module
$self->_load_module($arg[0]);
}
}
$self;
}
sub handle {
my ($self) = @_;
my ($obj, $res, $jsondata);
if ($self->request->method eq 'POST') {
$jsondata = $self->retrieve_json_from_post();
}
elsif ($self->request->method eq 'GET') {
$jsondata = $self->retrieve_json_from_get();
}
if ( $jsondata ) {
$obj = eval q| $self->json->decode($jsondata) |;
if ($@) {
$self->raise_error(code => 201, message => "Can't parse JSON data.");
}
}
else { # may have error_response_header at retroeve_json_from_post / get
unless ($self->error_response_header) {
$self->error_response_header($self->response_header(403, 'No data.'));
}
}
if ($obj) {
$res = $self->_handle($obj);
unless ($self->error_response_header) {
return $self->response( $self->response_header(200, $res) );
}
}
$self->response( $self->error_response_header );
}
sub retrieve_json_from_post { } # must be implemented in subclass
sub retrieve_json_from_get { } # must be implemented in subclass
sub response { } # must be implemented in subclass
sub raise_error {
my ($self, %opt) = @_;
my $status_code = $opt{status_code} || 200;
if (exists $opt{version} and $opt{version} ne '1.1') {
$self->version(0);
}
else {
$self->version(1.1);
}
my $res = $self->_error($opt{id}, $opt{code}, $opt{message});
$self->error_response_header($self->response_header($status_code, $res));
return;
}
sub response_header {
my ($self, $code, $result) = @_;
my $h = HTTP::Headers->new;
$h->header('Content-Type' => $self->content_type . '; charset=' . $self->charset);
HTTP::Response->new($code => undef, $h, $result);
}
sub _handle {
my ($self, $obj) = @_;
$obj->{version} ? $self->version(1.1) : $self->version(0);
my $method = $obj->{method};
if (!defined $method) {
return $self->_error($obj->{id}, 300, "method is nothing.");
}
elsif ($method =~ /[^-._a-zA-Z0-9]/) {
return $self->_error($obj->{id}, 301, "method is invalid.");
}
my $procedure = $self->_find_procedure($method);
unless ($procedure) {
return $self->_error($obj->{id}, 302, "No such a method : '$method'.");
}
my $params;
unless ($obj->{version}) {
unless ($obj->{params} and ref($obj->{params}) eq 'ARRAY') {
return $self->_error($obj->{id}, 400, "Invalid params for JSONRPC 1.0.");
}
}
unless ($params = $self->_argument_type_check($procedure->{argument_type}, $obj->{params})) {
return $self->_error($obj->{id}, 401, $self->error_message);
}
my $result;
if ($obj->{version}) {
$result = ref $params ? eval q| $procedure->{code}->($self, $params) |
: eval q| $procedure->{code}->($self) |
;
}
else {
my @params;
if(ref($params) eq 'ARRAY') {
@params = @$params;
}
else {
$params[0] = $params;
}
$result = eval q| $procedure->{code}->($self, @params) |;
}
if ($self->error_response_header) {
return;
}
elsif ($@) {
return $self->_error($obj->{id}, 500, ($self->return_die_message ? $@ : 'Procedure error.'));
}
if (!$obj->{version} and !defined $obj->{id}) { # notification
return '';
}
my $return_obj = {result => $result};
if ($obj->{version}) {
$return_obj->{version} = '1.1';
}
else {
$return_obj->{error} = undef;
$return_obj->{id} = $obj->{id};
}
return $self->json->encode($return_obj);
}
sub _find_procedure {
my ($self, $method) = @_;
my $found;
my $classname;
my $system_call;
if ($method =~ /^system\.(\w+)$/) {
$system_call = 1;
$method = $1;
}
elsif ($method =~ /\./) {
my @p = split/\./, $method;
$method = pop @p;
$classname= join('::', @p);
}
if ($self->{dispatch_path}) {
my $path = $self->{path_info};
if (my $pkg = $self->{dispatch_path}->{$path}) {
return if ( $classname and $pkg ne $classname );
return if ( $JSONRPC_Procedure_Able and JSON::RPC::Legacy::Procedure->can( $method ) );
$self->_load_module($pkg);
if ($system_call) { $pkg .= '::system' }
return $self->_method_is_ebable($pkg, $method, $system_call);
}
}
else {
for my $pkg (@{$self->{loaded_module}->{order}}) {
next if ( $classname and $pkg ne $classname );
next if ( $JSONRPC_Procedure_Able and JSON::RPC::Legacy::Procedure->can( $method ) );
if ($system_call) { $pkg .= '::system' }
if ( my $ret = $self->_method_is_ebable($pkg, $method, $system_call) ) {
return $ret;
}
}
}
return;
}
sub _method_is_ebable {
my ($self, $pkg, $method, $system_call) = @_;
my $allowable_procedure = $pkg->can('allowable_procedure');
my $code;
if ( $allowable_procedure ) {
if ( exists $allowable_procedure->()->{ $method } ) {
$code = $allowable_procedure->()->{ $method };
}
else {
return;
}
}
if ( $code or ( $code = $pkg->can($method) ) ) {
return {code => $code} if ($system_call or !$JSONRPC_Procedure_Able);
if ( my $procedure = JSON::RPC::Legacy::Procedure::check($pkg, $code) ) {
return if ($procedure->{return_type} and $procedure->{return_type} eq 'Private');
$procedure->{code} = $code;
return $procedure;
}
}
if ($system_call) { # if not found, default system.foobar
if ( my $code = 'JSON::RPC::Legacy::Server::system'->can($method) ) {
return {code => $code};
}
}
return;
}
sub _argument_type_check {
my ($self, $type, $params) = @_;
unless (defined $type) {
return defined $params ? $params : 1;
}
my $regulated;
if (ref $params eq 'ARRAY') {
if (@{$type->{position}} != @$params) {
$self->error_message("Number of params is mismatch.");
return;
}
if (my $hash = $type->{names}) {
my $i = 0;
for my $name (keys %$hash) {
$regulated->{$name} = $params->[$i++];
}
}
}
elsif (ref $params eq 'HASH') {
if (@{$type->{position}} != keys %$params) {
$self->error_message("Number of params is mismatch.");
return;
}
if (my $hash = $type->{names}) {
my $i = 0;
for my $name (keys %$params) {
if ($name =~ /^\d+$/) {
my $realname = $type->{position}[$name];
$regulated->{$realname} = $params->{$name};
}
else {
$regulated->{$name} = $params->{$name};
}
}
}
}
elsif (!defined $params) {
if (@{$type->{position}} != 0) {
$self->error_message("Number of params is mismatch.");
return;
}
return 1;
}
else {
$self->error_message("the params member is any other type except JSON Object or Array.");
return;
}
return $regulated ? $regulated : $params;
}
sub _load_module {
my ($self, $pkg) = @_;
eval qq| require $pkg |;
if ($@) {
Carp::croak $@;
}
$self->{loaded_module}->{name}->{$pkg} = $pkg;
push @{ $self->{loaded_module}->{order} }, $pkg;
}
# Error Handling
sub _error {
my ($self, $id, $code, $message) = @_;
if ($self->can('translate_error_message')) {
$message = $self->translate_error_message($code, $message);
}
my $error_obj = {
name => 'JSONRPCError',
code => $code,
message => $message,
};
my $obj;
if ($self->version) {
$obj = {
version => "1.1",
error => $error_obj,
};
$obj->{id} = $id if (defined $id);
}
else {
return '' if (!defined $id);
$obj = {
result => undef,
error => $message,
id => $id,
};
}
return $self->json->encode($obj);
}
##############################################################################
package JSON::RPC::Legacy::Server::system;
sub describe {
{
sdversion => "1.0",
name => __PACKAGE__,
summary => 'Default system description',
}
}
1;
__END__
=pod
=head1 NAME
JSON::RPC::Server - Perl implementation of JSON-RPC sever
=head1 SYNOPSIS
# CGI version
use JSON::RPC::Legacy::Server::CGI;
my $server = JSON::RPC::Legacy::Server::CGI->new;
$server->dispatch_to('MyApp')->handle();
# Apache version
# In apache conf
PerlRequire /your/path/start.pl
PerlModule MyApp
<Location /jsonrpc/API>
SetHandler perl-script
PerlResponseHandler JSON::RPC::Legacy::Server::Apache
PerlSetVar dispatch "MyApp"
PerlSetVar return_die_message 0
</Location>
# Daemon version
use JSON::RPC::Legacy::Server::Daemon;
JSON::RPC::Legacy::Server::Daemon->new(LocalPort => 8080);
->dispatch({'/jsonrpc/API' => 'MyApp'})
->handle();
# FastCGI version
use JSON::RPC::Legacy::Server::FastCGI;
my $server = JSON::RPC::Legacy::Server::FastCGI->new;
$server->dispatch_to('MyApp')->handle();
=head1 DESCRIPTION
Gets a client request.
Parses its JSON data.
Passes the server object and the object decoded from the JSON data to your procedure (method).
Takes your returned value (scalar or arrayref or hashref).
Sends a response.
Well, you write your procedure code only.
=head1 METHODS
=over
=item new
Creates new JSON::RPC::Legacy::Server object.
=item dispatch($package)
=item dispatch([$package1, $package1, ...])
=item dispatch({$path => $package, ...})
Sets your procedure module using package name list or arrayref or hashref.
Hashref version is used for path_info access.
=item dispatch_to
An alias to C<dispatch>.
=item handle
Runs server object and returns a response.
=item raise_error(%hash)
return $server->raise_error(
code => 501,
message => "This is error in my procedure."
);
Sets an error.
An error code number in your procedure is an integer between 501 and 899.
=item json
Setter/Getter to json encoder/decoder object.
The default value is L<JSON> object in the below way:
JSON->new->utf8
In your procedure, changes its behaviour.
$server->json->utf8(0);
The JSON coder creating method is C<create_json_coder>.
=item version
Setter/Getter to JSON-RPC protocol version used by a client.
If version is 1.1, returns 1.1. Otherwise returns 0.
=item charset
Setter/Getter to cahrset.
Default is 'UTF-8'.
=item content_type
Setter/Getter to content type.
Default is 'application/json'.
=item return_die_message
When your program dies in your procedure,
sends a return object with errror message 'Procedure error' by default.
If this option is set, uses C<die> message.
sub your_procedure {
my ($s) = @_;
$s->return_die_message(1);
die "This is test.";
}
=item retrieve_json_from_post
It is used by JSON::RPC::Legacy::Server subclass.
=item retrieve_json_from_get
In the protocol v1.1, 'GET' request method is also allowable.
It is used by JSON::RPC::Legacy::Server subclass.
=item response
It is used by JSON::RPC::Legacy::Server subclass.
=item request
Returns L<HTTP::Request> object.
=item path_info
Returns PATH_INFO.
=item max_length
Returns max content-length to your application.
=item translate_error_message
Implemented in your subclass.
Three arguments (server object, error code and error message) are passed.
It must return a message.
sub translate_error_message {
my ($s, $code, $message) = @_;
return $translation_jp_message{$code};
}
=item create_json_coder
(Class method)
Returns a JSON de/encoder in C<new>.
You can override it to use your favorite JSON de/encode.
=back
=head1 RESERVED PROCEDURE
When a client call a procedure (method) name 'system.foobar',
JSON::RPC::Legacy::Server look up MyApp::system::foobar.
L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html#ProcedureCall>
L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html#ServiceDescription>
There is JSON::RPC::Legacy::Server::system::describe for default response of 'system.describe'.
=head1 SEE ALSO
L<JSON>
L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html>
L<http://json-rpc.org/wiki/specification>
=head1 AUTHOR
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2007-2008 by Makamaka Hannyaharamitu
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut