File Coverage

blib/lib/JRPC.pm

Criterion	Covered	Total	%
statement	15	98	15.3
branch	0	52	0.0
condition	0	3	0.0
subroutine	5	11	45.4
pod	3	6	50.0
total	23	170	13.5

#{
package JRPC;
use JSON::XS;
use Data::Dumper;
use strict;
use warnings;

#UNUSED:my $rstub = {'id' => 66666, 'jsonrpc' => '2.0'};
our $VERSION = '0.61';
# 0 = No validation (trust client, any exceptions thrown because of errors will
#    be much lower level.)
# 1 = Validate method,params
# 2 = Require 'id','jsonrpc', 3
our $msgvalid = 1;
# This is prelogger callback. MUST be a _hard_ CODE ref to be used (not symbolic reference).
our $prelogger;

=head1 NAME

JRPC - Create JSON-RPC Services focusing on app logic, not worrying about the details of JSON-RPC Processing.

=head1 SYNOPSIS

   use JRPC;
   # Load one of the Service modules JRPC::CGI, JRPC::Apache2 or JRPC::Nginx
   # See particular submodule documentation for the details.
   use JRPC::CGI;

=head1 DESCRIPTION

JRPC Module bundle consists of Server and Client pieces for creating JSON-RPC services.
For the server piece it takes a slightly different approach than many other "API Heavy" CPAN modules.
Instead of assembing your service out of API calls, JRPC forms a framework on top of your implementation and
allows you to write a (single) callback:

=over 4

=item * receiving parameters (JSON-RPC "params") of the of JSON-RPC call pre-parsed, ready-to be worked with by your app code

=item * returning the "result" data (to framework taking care of JSON-RPC)

=back

The callback should be wrapped into a class package. One package can host multiple service methods.

When any exception is thrown (by die()) during the processing by callback, the framework takes care of turning this to an appropriate JSON-RPC fault.
The framework will also take care of dealing with JSON-RPC "envelope" (term borrowed from SOAP lingo) of both request and response, "unwrapping" it
on request and wrapping the result with it on response.

   package MyEchoService;
   our $VERSION = '0.01';

   # Respond with whatever was sent
   sub echo {
      my ($param) = @_;
      # Pass-through - Just send the "params" as "result"
      return($param);
   }

=head1 DISPATCHING OF SERVICE REQUEST

Dispatching of service request can use 2 methods:

=over 4

=item * URL based dispatching, where relative URL (after server name and port) defines the package and method name ("method" in JSON-RPC envelope) defines the runtime method

=item * URL independent dispatching where method name with dot-notation defines the method name

=back

Currently the dispatching method is automatically chosen based on what is found in "method" member of JSON-RPC envelope.
Examples highlighting the (automatically) chosen dispatching method:

=over 4

=item * "method": "echo", URL "/MyEchoService" - Choose URL based dispatching, map relative URL to package and echo() method ( MyEchoService::echo() )

=item * "method": "MyEchoService.echo" - Derive both Class and method from dot-notation ( MyEchoService::echo() )

=back

I'd recommend the latter as a more modern way of dispatching. Additionally (because of URL independence and need to "map" URL:s) it is less likely to require config changes in your web server.

=head1 METHODS

=head2 createfault($req, $msg, $errcode)

Internal method to create a JSON-RPC Fault message.
As these parameters are coming from the server side code, they are trusted
(i.e. not validated) here. Parameters:

=over 4

=item * $msg - Message (typically originating from exceptions). Placed to member "message" of
"error" branch of fault (See JSON-RPC 2.0 spec for details).

=item * $errcode - Numeric error code (must be given)

=back

Notice that the service methods should not be using this directly, but only be throwing exceptions.
As a current shortcoming, the service methods cannot set $errcode (Only basic string based exceptions are
currently allowed / accepted).

This should not be called explicitly by service developer. Throw execptions in your service handler to have them
automatically converted to valid JSON-RPC faults by createfault().

=cut
# =item * $data - ANY data to be attached to 'data' member of error/fault Object
sub createfault {
   my ($req, $msg, $errcode) = @_; # , $data
   # Create response stub  HERE ????
   # TODO: We could clone original or just pick 'id', 'jsonrpc' from it.
   my $resp = {'jsonrpc' => '2.0'}; # $req ? $req : Storable::dclone($rstub);
   $resp->{'id'} = $req->{'id'};
   #$req->{'id'} = $msg->{'id'};
   my $fault = $resp->{'error'} = {'message' => $msg, 'code' => $errcode, };
   #if ($data) {$fault->{'data'} = $data;}
   # Return data (structure) or serialized JSON ?
   #if (1) {}
   return(encode_json($resp));
   # Return apache return values, such as Apache2::Const::OK ?
}
# Note - these package global lazy-cached tables have different formats.
# Single level dot-notation to service method (CODE) mapping.
our %dotn2func = ();
# Two level URL => method => service method (CODE) mapping.
our %urlm2func = ();

#=head1 METHOD RESOLVER METHODS

#Both resolvers (Explained earlier in doc) are able to cache package+method combos in lookup tables for accelerated resolution.
# Both have their own cache / mapping table (containing re-resolved methods) for this purpose.
#Both resolver methods return a hard (CODE) reference to service for the server to execute.

# DONE: Build a pre-resolved method mapping table.
# TODO: Allow 'lazyload' for lazily loading modules on-demand.
# Should we do package AND method resolution in single method ?
sub methresolve_dotnot {
   my ($r, $m) = @_;
   # Support dot-notation (resolve_dotnot())
   if ($m !~ /\./) {die("No dot-notation in method");} # Redundant check
   # Resolved earlier, Pre-cached ?
   if (my $f = $dotn2func{$m}) {return($f);}
   my @pp = split(/\./, $m);
   my $mcp = pop(@pp); # pop() (trailing) method

   if (!$mcp) {die("No method remaining for dotnot method resolution ($m)".Dumper(\@pp));}
   if (!@pp) {die("No package path comps for dotnot method resolution ($m)".Dumper(\@pp));}

   if (my $f = join('::', @pp)->can($mcp)) {$dotn2func{$m} = $f;return($f);}
   return(undef);

}
# URL2package based Service Class/Method resolver
sub methresolve {
   my ($r, $m) = @_;
   # Extract Package from URL:
   # get the global request object (requires PerlOptions +GlobalRequest)
   #my $r = Apache2::RequestUtil->request;
   # Thankfully both Apache2 and Nginx have this method
   my $uri = $r->uri();
   if (my $f = $urlm2func{$uri}->{$m}) {return($f);}
   my @pp = split(/\//, $uri);
   # Normalize components
   if (!$pp[0]) {shift(@pp);}
   if (!$pp[$#pp]) {pop(@pp);}
   # $ENV{'SCRIPT_NAME'}
   #my $dump = Dumper(\%ENV); # $dump
   if (!@pp || !$pp[0]) {
     die("No package comps for method resolution (uri=$uri)");
   }
   my $mcp = join('::', @pp);
   my $f = $mcp->can($m);
   if (!$f) {die("Tried meth '$m' from package: '$mcp'");return(undef);}
   # Cache to a URL-to-method map (NOT methname-to-func)
   $urlm2func{$uri}->{$m} = $f;
   return($f);
   #return("qmp"->can($m));
}

=head2 parse($jsontext)

Parse JSON-RPC Message and validate the essential parts of it. What is validated (per JSON-RPC spec):

=over 4

=item * method - must be non-empty

=item * params - presence (of key) - even null (value) is okay.

=item * id - JSON-RPC ID of message - must be present (format not strictly constrained)

=item * jsonrpc - JSON-RPC protocol version (must be '2.0')

=back

The particular format of "params" (Object/Array/scalar) or individual parameter
validation in case of most common case "Object" is not in the scope here.

=cut
# TODO: Allow application level constraining of "params" to certain type (e.g. HASH/Object)
sub parse { # JRPC::Msg::
   #my ($buffer) = @_;
   my $j = eval { decode_json($_[0]); }; # $buffer / $_[0]
   if ($@) {die("Error Parsing JSON(-32700): $@");}

   # Error on batch requests
   if (ref($j) eq 'ARRAY') {die("JSON-RPC Batch request not (yet) supported");}
   # These validation steps have a slight cost (3800 => 3600 for simple
   # method processing where relative framework overhead is major).
   # Allow to skip them with a config
   #if (!$msgvalid) {
   return($j);
   #}
   #eval {
     # In order of importance method and params are necessary.
     if (!$j->{'method'}) {die("No 'method' found");}
     if (!exists($j->{'params'})) {die("No 'params' found");} # !(not) enough ?
     if ($msgvalid < 2) {return($j);}
     if (!$j->{'id'}) {die("No 'id' found");}
     if ($j->{'jsonrpc'} ne '2.0') {die("No jsonrpc version (2.0)found");}
     # Still validate envelope and param top level format

     # Additional params format constraint validation (fmtvalidator func ?)
     #if (my $fmt = $serv->{'pfmt'}) {}
   #};
   if ($@) {die("Invalid JSON-RPC Message (-32600): $@");}
   return($j);
}

#}; # END package JRPC;

=head2 respond_async($client, $url, $meth, $p, %opts);

After async processing, acknowledge the original client tier (or any URL) of the completion of the asynchronous part.
This method is experimental and the whole concept of using asynchronous processing at service is an unofficial extension
to standard JSON-RPC 2.0 protocol spec.

Parameters:

=over 4

=item * $client - Instance of JRPC::Client. If not provided, a new client will be instantiated here.

=item * $url - URL of the async callback - Must be provided

=item * $meth - JSON-RPC Method to callback to on the server (default: "oncomplete")

=item * $p - JSON-RPC "params" to send in completion acknowledgement (must be supplied, likely to be Object/Hash)

=back

If optional KW params in have param 'cb' set, it is used to process the response from callback service. The "result" of JSON-RPC response is passed to this callback.

Return "result" of response (likely to be Object/Hash).

=cut

#Minor optimization for avoiding overhead of JRPC::Client instantiation in respond_async() (or during request) is to initialize it in the service package init() phase.

# TODO: Example of combination of init and a call to respond_async()
# package MyPack;
# ...
#our $client;
#sub init {
#   $client = JRPC::Client->new();
#}
#sub do_long_and_hard_work {
#   my ($p) = @_;
#
#}
#TODO: Consider callback to handle specific response.
sub respond_async {
   my ($client, $url, $meth, $p, %c) = @_;
   #my $client = $opts{'client'}; # Allow passing client as optional ?
   # Create a full JRPC::Client instance if not passed.
   if (!$client) {$client = JRPC::Client->new();}
   if (!$url) {die("No Callback URL passed");}
   if (!$meth) {$meth = 'oncomplete';}
   if (!$p) {die("No Parameters passed");}
   # Always create a new request
   my $req = $client->new_request($url); # Client does not know URL, request does.
   if (!$req) {die("JSON-RPC Request not instantiated");}
   my $resp = $req->call($meth, $p, 'notify' => 1); # Need eval ?
   if (!$resp->is_success()) {die("HTTP Error: ".$resp->status_line());} # Status code ?
   #DEBUG:print($fh "Resp from '$url': ".$resp->content()."\n");
   # Server side may or may not care about this.
   # By default consider response as non-important as handling various specific responses here would
   # be hard.
   my $result = $resp->result();
   # Consider:Expect still a valid JSON response ? Parse it ?
   if (my $f = $c{'cb'}) {no strict 'refs';$f->($result);}
   return($result);
}

#setup_pkg_as_server($classname)
# Setup a Service package as independent, runnable server w.o. hard-wiring any
# code into a server package. Handy for testing a serice package.
# Loads HTTP::Server::Simple::CGI, JRPC::CGI, Attaches the "handle_request" callback method as request handler.
# After this setup all that remains to be done is to run the server (not done here).
# Complete example of making "MyServPkg" run.
#   use MyServPkg;
#   my $port = $ENV{'JSONRPC_SERVICE_PORT'} || 8080;
#   # Run in the same process
#   MyServPkg->new($port)->run();
sub setup_pkg_as_server {
   my ($class) = @_;
   # Bootstrapping boilerplate. We are (almost completely) n control of of $boot string here,
   # so eval is acceptable. Especially with validation of $class.
   if ($class !~ /^[\w:]+$/) {die("Class does not look right");} # No spaces
   my $boot =
   "use HTTP::Server::Simple::CGI;\npush(\@$class\:\:ISA, 'HTTP::Server::Simple::CGI');\nuse JRPC::CGI;\n";
   $boot .= "*$class\:\:handle_request = \\&JRPC::CGI::handle_simple_server_cgi;";
   #print(STDERR "$boot");
   eval("$boot");
}
1;
__END__