Permalink
Browse files

Initial import

  • Loading branch information...
0 parents commit 6065f06718c26fc83a53e9f91785a78f4fa5356d @claesjac committed Feb 11, 2011
Showing with 1,047 additions and 0 deletions.
  1. +6 −0 Changes
  2. +10 −0 MANIFEST
  3. +18 −0 Makefile.PL
  4. +72 −0 README
  5. +161 −0 lib/JSON/RPC/Simple.pm
  6. +155 −0 lib/JSON/RPC/Simple/Client.pm
  7. +408 −0 lib/JSON/RPC/Simple/Dispatcher.pm
  8. +9 −0 t/01-load.t
  9. +192 −0 t/02-dispatcher.t
  10. +16 −0 t/03-client.t
6 Changes
@@ -0,0 +1,6 @@
+Revision history for Perl extension JSON::RPC::Simple.
+
+0.01 Tue May 4 10:55:49 2010
+ - original version; created by h2xs 1.23 with options
+ -X -n JSON::RPC::Simple -b 5.8.0
+
10 MANIFEST
@@ -0,0 +1,10 @@
+Changes
+lib/JSON/RPC/Simple.pm
+lib/JSON/RPC/Simple/Client.pm
+lib/JSON/RPC/Simple/Dispatcher.pm
+Makefile.PL
+MANIFEST
+README
+t/01-load.t
+t/02-dispatcher.t
+t/03-client.t
18 Makefile.PL
@@ -0,0 +1,18 @@
+use 5.008000;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => "JSON::RPC::Simple",
+ VERSION_FROM => "lib/JSON/RPC/Simple.pm", # finds $VERSION
+ PREREQ_PM => {
+ "LWP::UserAgent" => 0,
+ "JSON" => 0,
+ "HTTP::Response" => 0,
+ "HTTP::Request" => 0,
+ "Test::Exception" => 0,
+ "Scalar::Util" => 0,
+ },
+ ABSTRACT_FROM => "lib/JSON/RPC/Simple.pm",
+ AUTHOR => "Claes Jakobsson <claesjac\@cpan.org>",
+ LICENSE => "perl",
+);
72 README
@@ -0,0 +1,72 @@
+NAME
+ JSON::RPC::Simple - Simple JSON-RPC client and dispatcher (WD 1.1 subset
+ only currently)
+
+SYNOPSIS
+ As client
+
+ use JSON::RPC::Simple;
+
+ my $client = JSON::RPC::Simple->connect("https://www.example.com/API/", {
+ timeout => 600,
+ });
+ my $r = $client->echo({ param1 => "value" });
+
+ As server:
+
+ package MyApp::API;
+
+ use base qw(JSON::RPC::Simple);
+
+ sub new { return bless {}, shift };
+
+ sub echo : JSONRpcMethod(Arg1, Arg2, Arg3) {
+ my ($self, $request, $args) = @_;
+ }
+
+ package MyApp::Handler;
+
+ my $dispatcher = JSON::RPC::Simple->dispatch_to({
+ "/API" => MyApp::API->new(),
+ "/OtherAPI" => "MyApp::OtherAPI",
+ });
+
+ sub handle {
+ my $request = shift; # Assume a HTTP::Request
+ my $response = $dispatcher->handle($request->uri->path, $request);
+ return $response; # Assume a HTTP::Response
+ }
+
+DESCRIPTION
+ This module is a very simple JSON-RPC 1.1 WD implementation that only
+ supports a subset of the specification.
+
+ It supports
+
+ HTTP POST only
+ Named and positonal arguments
+ Error objects
+
+USAGE
+ As a client
+ This module provides a class method for creating a client that works as
+ a shortcut to "JSON::RPC::Simple::Client->new(...)".
+
+ connect(URL)
+ connect(URL, \%OPTIONS)
+ Returns a new client for the given *URL* with the optional
+ *%OPTIONS*.
+
+ See "options" in JSON::RPC::Simple::Client for what options it
+ accepts.
+
+AUTHOR
+ Claes Jakobsson, <claesjac@cpan.org>
+
+COPYRIGHT AND LICENSE
+ Copyright (C) 2010-2011 by Claes Jakobsson and Glue Finance AB
+
+ This library is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself, either Perl version 5.10.0 or, at
+ your option, any later version of Perl 5 you may have available.
+
161 lib/JSON/RPC/Simple.pm
@@ -0,0 +1,161 @@
+package JSON::RPC::Simple;
+
+use 5.008000;
+use strict;
+use warnings;
+
+use Scalar::Util qw(blessed refaddr);
+use Carp qw(croak);
+
+our $VERSION = '0.01';
+
+our $ClientClass = "JSON::RPC::Simple::Client";
+sub connect {
+ my $pkg = shift;
+
+ require JSON::RPC::Simple::Client;
+
+ my $self = $ClientClass->new(@_);
+ return $self;
+}
+
+sub dispatch_to {
+ my $pkg = shift;
+
+ require JSON::RPC::Simple::Dispatcher;
+
+ my $self = JSON::RPC::Simple::Dispatcher->new();
+ return $self->dispatch_to(@_);
+}
+
+{
+ my %method_attributes;
+
+ sub FETCH_CODE_ATTRIBUTES {
+ my ($pkg, $code) = @_;
+
+ return unless exists $method_attributes{refaddr $code};
+ return $method_attributes{refaddr $code};
+ }
+
+ my $method_attr_re = qr{
+ ^
+ JSONRpcMethod
+ (?:\(\)|\(
+ \s*
+ (\w+ (\s*,\s* \w+)*)?
+ \s*
+ \))?
+ }sx;
+
+ sub MODIFY_CODE_ATTRIBUTES {
+ my ($class, $code, @attributes) = @_;
+
+ # Check if this contains a JSONRpcMethod attribute
+ my @bad;
+ for my $attribute (@attributes) {
+ if ($attribute =~ $method_attr_re) {
+ my @attrs = split /\s*,\s*/, ($1 || "");
+ $method_attributes{refaddr $code} = \@attrs;
+ }
+ else {
+ push @bad, $attribute;
+ }
+ }
+
+ return @bad;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+JSON::RPC::Simple - Simple JSON-RPC client and dispatcher (WD 1.1 subset only currently)
+
+=head1 SYNOPSIS
+
+As client
+
+ use JSON::RPC::Simple;
+
+ my $client = JSON::RPC::Simple->connect("https://www.example.com/API/", {
+ timeout => 600,
+ });
+ my $r = $client->echo({ param1 => "value" });
+
+As server:
+
+ package MyApp::API;
+
+ use base qw(JSON::RPC::Simple);
+
+ sub new { return bless {}, shift };
+
+ sub echo : JSONRpcMethod(Arg1, Arg2, Arg3) {
+ my ($self, $request, $args) = @_;
+ }
+
+ package MyApp::Handler;
+
+ my $dispatcher = JSON::RPC::Simple->dispatch_to({
+ "/API" => MyApp::API->new(),
+ "/OtherAPI" => "MyApp::OtherAPI",
+ });
+
+ sub handle {
+ my $request = shift; # Assume a HTTP::Request
+ my $response = $dispatcher->handle($request->uri->path, $request);
+ return $response; # Assume a HTTP::Response
+ }
+
+=head1 DESCRIPTION
+
+This module is a very simple JSON-RPC 1.1 WD implementation that only
+supports a subset of the specification.
+
+It supports
+
+=over 4
+
+=item HTTP POST only
+
+=item Named and positonal arguments
+
+=item Error objects
+
+=back
+
+=head1 USAGE
+
+=head2 As a client
+
+This module provides a class method for creating a client that works as a
+shortcut to C<JSON::RPC::Simple::Client-E<gt>new(...)>.
+
+=over 4
+
+=item connect(URL)
+
+=item connect(URL, \%OPTIONS)
+
+Returns a new client for the given I<URL> with the optional I<%OPTIONS>.
+
+See L<JSON::RPC::Simple::Client/options> for what options it accepts.
+
+=back
+
+=head1 AUTHOR
+
+Claes Jakobsson, E<lt>claesjac@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2010-2011 by Claes Jakobsson and Glue Finance AB
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.10.0 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
155 lib/JSON/RPC/Simple/Client.pm
@@ -0,0 +1,155 @@
+package JSON::RPC::Simple::Client;
+
+use strict;
+use warnings;
+
+use LWP::UserAgent;
+use JSON qw();
+
+require JSON::RPC::Simple;
+
+use constant DEFAULT_TIMEOUT => 180;
+
+sub new {
+ my ($pkg, $uri, $attrs) = @_;
+
+ $attrs = {} unless ref $attrs eq "HASH";
+
+ my $agent = delete $attrs->{agent} || "JSON::RPC::Simple " .
+ JSON::RPC::Simple->VERSION;
+
+ my $ua = LWP::UserAgent->new(
+ agent => $agent,
+ timeout => (
+ exists $attrs->{timeout} ?
+ delete $attrs->{timeout} :
+ DEFAULT_TIMEOUT
+ ),
+ );
+
+ my $self = bless {
+ json => JSON->new->utf8,
+ %$attrs,
+ ua => $ua,
+ uri => $uri,
+ }, $pkg;
+
+ return $self;
+}
+
+sub DESTROY {
+ # or AUTOLOAD will pick this up
+}
+
+my $next_request_id = 0;
+
+our $AUTOLOAD;
+sub AUTOLOAD {
+ my ($self, $params) = @_;
+
+ my $method = $AUTOLOAD;
+ $method =~ s/.*:://;
+
+ my $id = ++$next_request_id;
+
+ my $content = $self->{json}->encode({
+ version => "1.1",
+ method => $method,
+ params => $params,
+ id => $id,
+ });
+
+ my $r = $self->{ua}->post(
+ $self->{uri},
+ Content_Type => "application/json; charset=UTF-8",
+ Accept => 'application/json',
+ Content => $content,
+ );
+
+ if ($r->is_success) {
+ die "Bad response" unless $r->content_type =~ m{^application/json};
+ }
+ else {
+ die $r->decoded_content unless $r->content_type =~ m{^application/json};
+ }
+
+ my $result;
+ eval {
+ my $content = $r->decoded_content;
+ print STDERR "Raw content: '\n${content}\n'\n" if $self->{debug};
+ $result = $self->{json}->decode($r->decoded_content);
+ };
+ die $@ if $@;
+ die "Didn't get a JSON object back" unless ref $result eq "HASH";
+ die $result->{error}->{message} if $result->{error};
+
+ return $result->{result};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+JSON::RPC::Simple::Client - JSON-RPC 1.1 WD client
+
+=head1 SYNOPSIS
+
+ use JSON::RPC::Simple::Client;
+
+ my $c = JSON::RPC::Simple::Client->new("https://www.example.com/json-rpc");
+
+ my $results = $c->echo("foo");
+
+=head1 USAGE
+
+This class uses an AUTOLOAD subroutine so that any method calls are sent to
+the target JSON-RPC service.
+
+To create a new client either use the C<new> method in directly or via the
+helper function C<JSON::RPC::Simple->connect>.
+
+=over 4
+
+=item new (URL)
+
+=item new (URL, \%OPTIONS)
+
+Creates a new client whos endpoint is given in I<URL>.
+
+Valid options:
+
+=over 4
+
+=item agent
+
+What to send as HTTP User-Agent, defaults to "JSON::RPC::Simple <version>"
+where version is the current version number of the JSON::RPC::Simple package.
+
+=item timeout
+
+Timeout for how long the call may take. Is passed to LWP::UserAgent which is
+used to make the request by default. Defaults to 180 sec
+
+=item json
+
+The JSON encoder/decoder to use. Defaults to JSON->new->utf8. The supplied
+object/class must respond to C<encode> and C<decode>.
+
+=item debug
+
+Turn on debugging which prints to STDERR.
+
+=back
+
+=back
+
+=head1 Using another transporter than LWP::UserAgent
+
+By default this class uses LWP::UserAgent. If you wish to use something else
+such as for example WWW::Curl simply replace the C<ua> member of the instance
+with something that provides a LWP::UserAgent compatible API for C<post>. The
+returned object from the C<post> method is expected to provide C<is_success>,
+C<decoded_content> and C<content_type>.
+
+=pod
408 lib/JSON/RPC/Simple/Dispatcher.pm
@@ -0,0 +1,408 @@
+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);
+ }
+
+ unless (defined $request->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 = attributes::get($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;
+}
+
+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<JSON> with utf8 on.
+
+=item charset
+
+The charset to send in the content-type when creating the response. Defaults
+to C<utf-8>.
+
+=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
9 t/01-load.t
@@ -0,0 +1,9 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+BEGIN { use_ok("JSON::RPC::Simple"); }
+
192 t/02-dispatcher.t
@@ -0,0 +1,192 @@
+#!/usr/bin/perl
+
+package MyApp::Service;
+
+use strict;
+use warnings;
+
+use bytes;
+
+use Test::More tests => 22;
+use Test::Exception;
+
+use HTTP::Request;
+use JSON qw(encode_json);
+
+use base qw(JSON::RPC::Simple);
+
+BEGIN { use_ok("JSON::RPC::Simple::Dispatcher"); }
+
+my $dispatcher = JSON::RPC::Simple->dispatch_to({});
+isa_ok($dispatcher, "JSON::RPC::Simple::Dispatcher");
+
+throws_ok {
+ $dispatcher->dispatch_to({
+ "/API" => "MyApp::Test1",
+ });
+} qr{Target for "/API" is not a JSON::RPC::Simple};
+
+lives_ok {
+ $dispatcher->dispatch_to({
+ "/API" => "MyApp::Service",
+ });
+} "Ok to make dispatch table";
+
+sub echo : JSONRpcMethod {
+ my ($self, $request, $args) = @_;
+
+ is($self, "MyApp::Service", "self is a MyAPP::Server");
+ isa_ok($request, "HTTP::Request", "request is a HTTP::Request");
+ is(ref $args, "HASH", "args is a hashref");
+
+ return $args->{value};
+}
+
+my $json = encode_json({
+ version => "1.1",
+ method => "echo",
+ params => {},
+});
+my $request = HTTP::Request->new(
+ POST => "http://localhost/API",
+ [ "Content-Type" => "application/json",
+ "Content-Length" => bytes::length($json)
+ ],
+ $json,
+);
+
+my $response = $dispatcher->handle("/API", $request);
+ok(!$dispatcher->errstr, "Got no error");
+
+sub echo_transform_args : JSONRpcMethod(Id, Name, Arg) {
+ my ($self, $request, $args) = @_;
+
+ is_deeply($args, {
+ Id => 200,
+ Name => "Foobar",
+ Arg => undef
+ }, "Transform positional to named");
+
+ 1;
+}
+
+$json = encode_json({
+ version => "1.1",
+ method => "echo_transform_args",
+ params => [200, "Foobar"],
+});
+$request = HTTP::Request->new(
+ POST => "http://localhost/API",
+ [ "Content-Type" => "application/json",
+ "Content-Length" => bytes::length($json)
+ ],
+ $json,
+);
+
+$dispatcher->handle("/API", $request);
+ok(!$dispatcher->errstr, "Got no error");
+
+our $JSONRPC_AUTOLOAD;
+
+my $called_autoload = 0;
+my $called_autoload_attrs = 0;
+sub JSONRPC_AUTOLOAD_ATTRS {
+ my ($self, $request) = @_;
+
+ is($self, "MyApp::Service", "self in autoloaded attrs is MyApp::Server");
+ isa_ok($request, "HTTP::Request", "request in autoloaded attrs is HTTP::Request");
+
+ $called_autoload_attrs = 1;
+ return [];
+}
+
+sub JSONRPC_AUTOLOAD {
+ my ($self, $request, $args) = @_;
+
+ is($self, "MyApp::Service");
+ isa_ok($request, "HTTP::Request");
+ is(ref $args, "HASH");
+
+ $called_autoload = 1;
+ is($JSONRPC_AUTOLOAD, "autoloaded");
+}
+
+$json = encode_json({
+ version => "1.1",
+ method => "autoloaded",
+ params => {},
+});
+$request = HTTP::Request->new(
+ POST => "http://localhost/API",
+ [ "Content-Type" => "application/json",
+ "Content-Length" => bytes::length($json)
+ ],
+ $json,
+);
+
+$response = $dispatcher->handle("/API", $request);
+ok($called_autoload);
+ok($called_autoload_attrs);
+ok(!$dispatcher->errstr);
+
+sub dies : JSONRpcMethod {
+ my ($self, $request, $args) = @_;
+
+ die "arg";
+}
+
+sub dies_modifying_error : JSONRpcMethod {
+ my ($self, $request, $args) = @_;
+
+ $JSON::RPC::Simple::Dispatcher::HTTP_ERROR_CODE=200;
+
+ die "arg";
+}
+
+$json = encode_json({
+ version => "1.1",
+ method => "dies",
+ params => {},
+});
+$request = HTTP::Request->new(
+ POST => "http://localhost/API",
+ [ "Content-Type" => "application/json",
+ "Content-Length" => bytes::length($json)
+ ],
+ $json,
+);
+
+$response = $dispatcher->handle("/API", $request);
+is($response->code, 500);
+
+$json = encode_json({
+ version => "1.1",
+ method => "dies_modifying_error",
+ params => {},
+});
+$request = HTTP::Request->new(
+ POST => "http://localhost/API",
+ [ "Content-Type" => "application/json",
+ "Content-Length" => bytes::length($json)
+ ],
+ $json,
+);
+
+$response = $dispatcher->handle("/API", $request);
+is($response->code, 200);
+
+$json = encode_json({
+ version => "1.1",
+ method => "dies",
+ params => {},
+});
+$request = HTTP::Request->new(
+ POST => "http://localhost/API",
+ [ "Content-Type" => "application/json",
+ "Content-Length" => bytes::length($json)
+ ],
+ $json,
+);
+
+$response = $dispatcher->handle("/API", $request);
+is($response->code, 500);
16 t/03-client.t
@@ -0,0 +1,16 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+use JSON::RPC::Simple;
+
+BEGIN { use_ok("JSON::RPC::Simple::Client"); }
+
+use constant SERVER_ADDR => "http://www.raboof.com/Projects/Jayrock/Demo.ashx";
+my $client = JSON::RPC::Simple->connect(SERVER_ADDR);
+
+my $r = $client->echo("Hello World");
+is($r, "Hello World");

0 comments on commit 6065f06

Please sign in to comment.