##############################################################################
# JSONRPC version 1.1
# http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html
##############################################################################

use strict;
use JSON::PP ();
use Carp ();

use HTTP::Request ();
use HTTP::Response ();


##############################################################################

package JSON::RPC::Server;

my $JSONRPC_Procedure_Able;

BEGIN {
    if ($] >= 5.006) {
        require  JSON::RPC::Procedure;
        $JSONRPC_Procedure_Able = 1;
    }
}

use Data::Dumper;

$JSON::RPC::Server::VERSION = '0.01';

BEGIN {
    require JSON::RPC::Procedure;

    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 new {
    my $class = shift;

    bless {
        max_length    => 1024 * 100,
        charset       => 'UTF-8',
        content_type  => 'application/json',
        json          => JSON::PP->new->utf8, # assumes UTF8
        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);

            $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);

            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) = @_;

    if (my $code = $pkg->can($method)) {
        return {code =>  $code} if ($system_call or !$JSONRPC_Procedure_Able);

        if ( my $procedure = JSON::RPC::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::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::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::Server::CGI;
 
 my $server = JSON::RPC::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::Server::Apache
      PerlSetVar dispatch "MyApp"
 </Location>
 
 
 
 # Daemon version
 use JSON::RPC::Server::Daemon;
 
 my JSON::RPC::Server::Daemon->new(LocalPort => 8080);
                             ->dispatch({'/jsonrpc/API' => 'MyApp'})
                             ->handle();


=head1 DESCRIPTION

Gets a client request.

Parses JSON data.

Passes itself (server object) and object(s) decoded from JSON data to your procedure (method).

Takes your return 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::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.

=item raise_error(%hash)

 return $server->raise_error(
    code => 501,
    message => "This is error in my procedure."
 );

An error code number in your procedure is an integer between 501 and 899.


=item json

Setter/Getter to json encoder/decoder object.
Default is L<JSON::PP>:

 JSON::PP->new->utf8

In your procedure, changes its behaviour.

 $server->json->utf8(0);


=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::Server subclass.


=item retrieve_json_from_get

In protocol v1.1, 'GET' request method is allow.

It is used by JSON::RPC::Server subclass.

=item response

It is used by JSON::RPC::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};
 }

=back


=head1 RESERVED PROCEDURE

When a client call a procedure (method) name 'system.foobar',
JSON::RPC::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::Server::system::describe for default response of 'system.describe'.


=head1 SEE ALSO

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 by Makamaka Hannyaharamitu

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut


