File Coverage

blib/lib/JSON/RPC/Simple/Dispatcher.pm

Criterion	Covered	Total	%
statement	114	152	75.0
branch	40	74	54.0
condition	10	23	43.4
subroutine	16	18	88.8
pod	6	10	60.0
total	186	277	67.1

package JSON::RPC::Simple::Dispatcher;

use strict;
use warnings;

use Carp qw(croak);
use HTTP::Response;
use JSON qw();

sub new {
    my ($pkg, $args) = @_;

    $args = {} unless ref $args eq "HASH";

    my $self = bless {
        charset => "UTF-8",
        json => JSON->new->utf8,
        error_handler => undef,
        %$args,
        target => {}
    }, $pkg;
    return $self;
}

sub json {
    my $self = shift;
    $self->{json} = shift if @_;
    return $self->{json};
}

sub error_handler {
    my $self = shift;
    $self->{error_handler} = shift if @_;
    return $self->{error_handler};
}

sub charset {
    my $self = shift;
    $self->{charset} = shift if @_;
    return $self->{charset};
}

sub dispatch_to {
    my ($self, $targets) = @_;

    croak "Targets is not hash reference" unless ref $targets eq "HASH";

    while (my ($path, $target) = each %$targets) {
        unless ($target->isa("JSON::RPC::Simple")) {
            croak qq{Target for "${path}" is not a JSON::RPC::Simple};
        }
        $self->{target}->{$path} = $target;
    }

    return $self;
}

sub JSONRPC_ERROR { undef; }

our $HTTP_ERROR_CODE;
sub _error {
    my ($self, $request, $id, $code, $message, $error_obj, $call, $target) = @_;

    $message = "Uknown error" unless defined $message;

    my $error = {
        (defined $id ? (id => $id) : ()),
        version => "1.1",
        error   => {
            name    => "JSONRPCError",
            code    => int($code),
            message => $message,
        },
    };

    if ($error_obj) {
        $error->{error}->{error} = $error_obj;
    }
    else {
        # No error object provided
        # Here, if there's a error callback handler registered on the
        # target first user that, secondly check if there's an
        # error handler on the dispatcher
        my $new_error_obj;
        if ($target && $target->can("JSONRPC_ERROR")) {
            $new_error_obj = $target->JSONRPC_ERROR(
                $request, $code, $message, $call
            );
        }
        $new_error_obj = $self->JSONRPC_ERROR unless $new_error_obj;
        if ($self->error_handler && !$new_error_obj) {
            $new_error_obj = $self->error_handler->(
                $request, $code, $message, $call, $target
            );
        }

        $error->{error}->{error} = $new_error_obj if $new_error_obj;
    }

    my $status_line = $HTTP_ERROR_CODE == 200 ? "OK" : "Internal Server Error";
    return $self->_encode_response($HTTP_ERROR_CODE, $status_line, $error);
}

sub _encode_response {
    my ($self, $code, $message, $response) = @_;

    my $content = $self->json->encode($response);
    my $h = HTTP::Headers->new();
    $h->header("Content-Type" => "application/json; charset=" . $self->charset);
    $h->header("Content-Length" => length $content);

    return HTTP::Response->new($code, $message, $h, $content);
}

sub errstr {
    return shift->{errstr} || "";
}

sub errobj {
    return shift->{errobj};
}

sub handle {
    my ($self, $path, $request) = @_;

    $HTTP_ERROR_CODE = 500;

    # Clear any previous errors
    delete $self->{errstr};

    # Don't support GET or other methods
    unless ($request->method eq "POST") {
        $self->{errstr} = "I only do POST";
        return $self->_error($request, undef, 0, $self->errstr);
    }

    unless ($request->content_type =~ m{^application/json}) {
        $self->{errstr} =
            "Invalid Content-Type, got '" . $request->content_type . "'";
        return $self->_error($request, undef, 0, $self->errstr);
    }

    # Some requests, like HTTP::Request lazy load content_length so we can't ->can("") it which is why the eval
    my $content_length = eval { $request->content_length };
    if ($@) {
        # Apache2::RequestReq
        $content_length = $request->headers_in->{'Content-Length'} if $request->can("headers_in");

        # Fallback
        $content_length = $request->headers->{'Content-Length'} if !defined $content_length && $request->can("headers");
    };

    unless (defined $content_length) {
        $self->{errstr} =
            "JSON-RPC 1.1 requires header Content-Length to be specified";
        return $self->_error($request, undef, 0, $self->errstr);
    }

    # Find target
    my $target = $self->{target}->{$path};

    # Decode the call and trap errors because it might
    # be invalid JSON
    my $call;
    eval {
        my $content = $request->content;

        # Remove utf-8 BOM if present
        $content =~ s/^(?:\xef\xbb\xbf|\xfe\xff|\xff\xfe)//;

        $call = $self->json->decode($content);
    };
    if ($@) {
        $self->{errstr} = "$@";
        $self->{errobj} = $@;
        return $self->_error(
            $request, undef, 0, $self->errstr, undef, undef, $target
        );
    }

    my $id = $call->{id};
    my $version = $call->{version};
    unless (defined $version) {
        $self->{errstr} = "Missing 'version'";
        return $self->_error(
            $request, $id, 0, $self->errstr, undef, $call, $target
        );
    }
    unless ($version eq "1.1") {
        $self->{errstr} = "I only do JSON-RPC 1.1";
        return $self->_error(
            $request, $id, 0, $self->errstr, undef, $call, $target
        );
    }

    my $method = $call->{method};
    unless ($method) {
        $self->{errstr} = "Missing method";
        $self->_error($request, $id, 0, $self->errstr, undef, $call, $target);
    }


    my $params = $call->{params};
    unless ($params) {
        $self->_error($id, 0, $self->errstr, undef, $call, $target);
    }

    unless (ref $params eq "HASH" || ref $params eq "ARRAY") {
        $self->{errstr} = "Invalid params, expecting object or array";
        return $self->_error(
            $request, $id, 0, $self->errstr, undef, $call, $target
        );
    }

    unless ($target) {
        $self->{errstr} = "No target for '${path}' exists";
        return $self->_error(
            $request, $id, 0, $self->errstr, undef, $call, $target
        );
    }

    my $cv = $target->can($method);
    my $check_attrs;
    if ($cv) {
        # Check that it's a JSONRpcMethod
        my @attrs = JSON::RPC::Simple->fetch_method_arguments($cv);
        unless (@attrs) {
            $self->{errstr} = "Procedure not found";
            return $self->_error(
                $request, $id, 0, $self->errstr, undef, $call, $target
            );
        }
        $check_attrs = shift @attrs;
    }
    else {
        # Check for fallback
        if ($cv = $target->can("JSONRPC_AUTOLOAD")) {
            my $pkg = ref $target || $target;
            no strict 'refs';
            ${"${pkg}::JSONRPC_AUTOLOAD"} = $method;

            if (my $attrs_cv = $target->can("JSONRPC_AUTOLOAD_ATTRS")) {
                my @attrs = $attrs_cv->($target, $request);
                unless (@attrs) {
                    $self->{errstr} = "Procedure not found";
                    return $self->_error(
                        $request, $id, 0, $self->errstr, undef, $call, $target
                    );
                }
                $check_attrs = shift @attrs;
            }
        }
        else {
            $self->{errstr} = "Procedure not found";
            return $self->_error(
                $request, $id, 0, $self->errstr, undef, $call, $target
            );
        }
    }

    # Named arguments defined,
    if ($check_attrs && @$check_attrs && ref $params eq "ARRAY") {
        my %named_params = map {
            $_ => shift @$params
        } @$check_attrs;
        $params = \%named_params;
    }

    my $rval;
    eval {
        $rval = $cv->($target, $request, $params);
    };
    if ($@) {
        $self->{errstr} = "$@";
        $self->{errobj} = $@;
        return $self->_error($request, $id, @{$@}) if ref $@ eq "ARRAY";
        return $self->_error($request, $id, 0, "$@", undef, $call, $target);
    }

    my $response;
    eval {
        $response = $self->_encode_response(200, "OK", {
            (defined $id ? (id => $id) : ()),
            version => "1.1",
            result  => $rval,
        });
    };
    if ($@) {
        $self->{errstr} = "$@";
        $self->{errobj} = $@;
        return $self->_error(
            $request, $id, 0, "Failed to encode response", undef, $call, $target
        );
    }

    return $response;
}

sub target {
    my ($self, $target) = @_;
    return $self->{target}->{$target};
}

1;

=head1 NAME

JSON::RPC::Simple::Dispatcher - Decodes JSON-RPC calls and dispatches them

=head1 DESCRIPTION

Instances of this class decodes JSON-RPC calls over HTTP and dispatches them to
modules/objects registered for a given path and then encodes the result as in a
JSON-RPC format.

=head1 INTERFACE

=head2 CLASS METHODS

=over 4

=item new ( %opts )

Creates a new dispatcher instance. Can take the the following optional named
arguments:

=over 4

=item json

The encoder/decoder object to use. Defaults to L with utf8 on.

=item charset

The charset to send in the content-type when creating the response. Defaults
to C.

=item error_handler

A reference to a subroutine which is invoked when an error occurs. May
optionally return an object which will be sent as the 'error' member of the
result. When called it is passed the request object, the error code, error
message, the call ID and target object if any.

=back

=back

=head2 CLASS VARIABLES

=over 4

=item $HTTP_ERROR_CODE

This is the HTTP result code. It's reset to 500 (Internal Server Error) each
time handle is called. You may change this in your error handling routine.

=back

=head2 INSTANCE METHODS

=over 4

=item json

=item json ( $json )

Gets/sets the json object to use for encoding/decoding

=item charset

=item charset ( $charset )

Gets/sets the charset to use when creating the HTTP::Response object.

=item error_handler ( \&handler )

Gets/sets the error handler to call when an error occurs.

=item dispatch_to ( \%targets )

Sets the dispatch table. The dispatch-table is a path to instance mapping where
the key is a path and the value the instance of class for which to call the
method on. For example

  $o->dispatch_to({
    "/API" => "MyApp::API",
    "/Other/API" => MyApp::OtherAPI->new(),
  });

=item handle ( $path, $request )

This method decodes the $request which should be a HTTP::Request look-a-like
object and finds the appropriate target in the dispatch table for $path.

The $request object MUST provide the following methods:

=over 4

=item method

The HTTP method of the request such as GET, POST, HEAD, PUT in captial letters.

=item content_type

The Content-Type header from the request.

=item content_length

The Content-Length header from the request.

=item content

The content of the request as we only handle POST.

=back

The content is stripped from any unicode BOM before being passed to the JSON
decoder.

=back

=cut