root/lang/perl/POE-Component-Server-JSONRPC/trunk/lib/POE/Component/Server/JSONRPC.pm @ 14290

package POE::Component::Server::JSONRPC;
use MooseX::POE;

use JSON::RPC::Common::Message;
use JSON::RPC::Common::Procedure::Call;
use JSON::RPC::Common::Procedure::Return;

our $VERSION = '0.02';

use POE qw(
    Component::Server::TCP
    Filter::Stackable
    Filter::JSON::Incr
    Filter::JSONRPC::Stream
);

use namespace::clean -except => [qw(meta)];

with qw(MooseX::POE::Aliased);

=head1 NAME

POE::Component::Server::JSONRPC - POE tcp based JSON-RPC server

=head1 SYNOPSIS

    use POE qw(Component::Server::JSONRPC);

    POE::Session->create(
        inline_states => {
            _start => sub {
                POE::Component::Server::JSONRPC->new(
                    Port    => 3000,
                    Handler => {
                        'echo' => 'echo',
                        'sum'  => 'sum',
                    },
                );
            },
            echo => \&echo,
            sum => \&sum,
        },
    );

    sub echo {
        my ($kernel, $jsonrpc, @params) = @_[KERNEL, ARG0..$#_ ];
    
        $kernel->post( $jsonrpc => 'result' => @params );
    }
    
    sub sum {
        my ($kernel, $jsonrpc, @params) = @_[KERNEL, ARG0..$#_ ];
    
        $kernel->post( $jsonrpc => 'result' => $params[0] + $params[1] );
    }

=head1 DESCRIPTION

This module is a POE component for tcp based JSON-RPC Server.

The specification is defined on http://json-rpc.org/ and this module use JSON-RPC 1.0 spec (1.1 does not cover tcp streams)

=head1 METHODS

=head2 new

Create JSONRPC component session and return the session id.

Parameters:

=over

=item Handler

Hash variable contains handler name as key, handler poe state name as value.

Handler name (key) is used as JSON-RPC method name.

So if you send {"method":"echo"}, this module call the poe state named "echo".

=back

=cut

has handler => (
    isa => "CodeRef|Str|HashRef",
    is  => "rw",
);

has _parent => (
    default => sub { $poe_kernel->get_active_session->ID },
    is  => "rw",
);

has _tcp => (
    is  => "rw",
);

has tcp => (
    isa => "HashRef",
    is  => "rw",
    required => 1,
);

has default_version => (
    isa => "Str",
    is  => "rw",
    default => sub { "1.0" }
);

has return_class => (
    isa => "ClassName",
    is  => "rw",
    lazy_build => 1,
    handles => { "create_return" => "new_from_data" },
);

sub _build_return_class {
    my $self = shift;

    my $class = JSON::RPC::Common::Procedure::Return->_version_class( $self->default_version );

    Class::MOP::load_class($class);

    return $class;
}

=head1 HANDLER PARAMETERS

=over

=item ARG0

A callback you can invoke to return results.

=item ARG1

The L<JSON::RPC::Common> object.

=back

=head1 HANDLER RESPONSE

    $_[ARG0]->( "result value" );

If you do above, response is:

   {"result":"result value", "error":"", id:...}

=head1 EVENTS

Two events same as PoCo::Server::TCP are supported.

=head2 shutdown

Shuts down TCP server.

=cut

event shutdown => sub {
    my ($self, $kernel) = @_[OBJECT, KERNEL];
    $kernel->post( $self->_tcp => 'shutdown' );
};

=head2 set_concurrency

Set the number of simultaneous connections

For more infomation about these events, see L<POE::Component::Server::TCP>.

=cut

event set_concurrency => sub {
    my ($self, $kernel, @args) = @_[OBJECT, KERNEL, ARG0..$#_];
    $kernel->post( $self->_tcp => set_concurrency => @args );
};

=head1 POE METHODS

Inner method for POE states.

=head2 poe__start

=cut

sub START {
    my ($self, $kernel, $session) = @_[OBJECT, KERNEL, SESSION];

    my $f = POE::Filter::Stackable->new(
        Filters => [
            POE::Filter::JSON::Incr->new(
                errors => 1,
                json_opts => [qw(utf8)]
            ),
            POE::Filter::JSONRPC::Stream->new(),
        ],
    );

    $self->_tcp(
        POE::Component::Server::TCP->new(
            %{ $self->tcp },
            ClientInput  => sub { $_[KERNEL]->call( $session => tcp_input_handler => $_[HEAP]{client}, @_[ARG0..$#_]) },
            ClientFilter => $f,
        ),
    );
}

=head2 poe_tcp_input_handler

=cut

event tcp_input_handler => sub {
    my ($self, $kernel, $client, $msg) = @_[OBJECT, KERNEL, ARG0, ARG1 ];

    if ( blessed($msg) ) {
        if ( $msg->isa("JSON::RPC::Common::Procedure::Call") ) {
            my $handler = $self->handler;

            if ( ref($handler) eq 'HASH' ) {
                unless ($handler = $handler->{ $msg->method }) {
                    $kernel->yield('error', $client, sprintf qq{no such method "%s"}, $msg->method, $msg);
                    return;
                }
            }

            my $cb = sub {
                if ( do { local $@; eval { $_[0]->does("JSON::RPC::Common::Message") } } ) {
                    $client->put($_[0]);
                } else {
                    $client->put( $msg->return_result(@_) );
                }
            };

            if ( ref $handler ) {
                $handler->( $cb, $msg, $client );
            } else {
                $kernel->post( $self->_parent, $handler, $cb, $msg, $client );
            }
        } else {
            # FIXME result, track req IDs, map back
        }
    } else {
        $msg = (split /\n/, $msg)[0];
        $msg =~ s/ at .+? line \d+//;
        $kernel->yield(error => $client, $msg);
    }
};

=head2 poe_error

=cut

event error => sub {
    my ($self, $kernel, $client, $error, $call) = @_[OBJECT, KERNEL, ARG0 .. ARG2];

    $client->put( $call ? $call->return_error($error) : $self->new_error($error) );
};

sub new_error {
    my ( $self, @args ) = @_;

    $self->create_return(
        id    => undef,
        error => ( @args % 2 == 0 ? {@args} : $args[0] || "Invalid request" ),
    );
};

=head1 AUTHOR

Daisuke Murase <typester@cpan.org>

=head1 COPYRIGHT

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

The full text of the license can be found in the
LICENSE file included with this module.

=cut

1;