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

##############################################################################
# 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__