File Coverage

blib/lib/JRPC/CGI.pm
Criterion Covered Total %
statement 15 66 22.7
branch 0 22 0.0
condition 0 3 0.0
subroutine 5 9 55.5
pod 2 4 50.0
total 22 104 21.1


line stmt bran cond sub pod time code
1             package JRPC::CGI;
2             # Leave this up to the implementor ?
3             #use CGI;
4             #use CGI::Carp qw/fatalsToBrowser warningsToBrowser/;
5 1     1   913 use JSON::XS;
  1         1  
  1         48  
6 1     1   4 use JRPC;
  1         0  
  1         13  
7 1     1   3 use strict;
  1         1  
  1         20  
8 1     1   3 use warnings;
  1         1  
  1         21  
9 1     1   4 use Scalar::Util ('reftype'); # Check base types
  1         1  
  1         593  
10              
11             =head1 NAME
12              
13             JRPC::CGI - JSON-RPC 2.0 Processing for CGI and HTTP::Server::Simple::CGI
14              
15             =head1 DESCRIPTION
16              
17             This package provides JSON-RPC 2.0 services processor for 2 runtimes based on:
18              
19             =over 4
20              
21             =item * CGI (CGI.pm) Plain old CGI scripting (or mod_perl ModPerl::Registry mode)
22              
23             =item * HTTP::Server::Simple::CGI - a fast and lightweight runtime with a Perl embedded httpd (web server) module.
24              
25             =back
26              
27             HTTP::Server::Simple::CGI is especially interesting for doing distributed computation over the http.
28              
29             =head1 METHODS
30              
31             Because of the rudimentary nature of CGI (in both good and bad), the JRPC::CGI::handle_cgi($cgi) is to be called explicitly in code
32             (as CGI is not hosted by sophisticated server).
33              
34             The service method JRPC::CGI::handle_simple_server_cgi($server, $cgi); for HTTP::Server::Simple::CGI can be aliased to local package's handle_request
35             method, which is the request handling method for HTTP::Server::Simple framework (similar to mod_perl's and Nginx's handler($r) method).
36              
37             =cut
38              
39             our $mimetype = 'text/plain';
40             # Plug for uri-method transparency
41             # Do NOT use CGI::url method for uri purpose !
42             # Keep this anywhere that may use CGI request object
43 0     0 0   sub CGI::uri {return $_[0]->script_name();}
44             # JSON RPC Response ID for malformed requests.
45             our $naid = 666666666;
46              
47             =head2 JRPC::CGI::handle_cgi($cgi)
48              
49             Traditional CGI Handler for JRPC. Example CGI wrapper:
50              
51             #!/usr/bin/perl
52             use CGI;
53             use CGI::Carp qw/fatalsToBrowser warningsToBrowser/;
54             use JRPC::CGI;
55             use SvcTest; # Load Service package
56             my $cgi = CGI->new();
57             # Process request. Reports all errors to Client as a JSON-RPC error (fault) response.
58             JRPC::CGI::handle_cgi($cgi);
59             exit(0);
60            
61             # This "Service Package" could (and should) be in a separate file (SvcTest.pm).
62             # It will be called back by JRPC.
63             package SvcTest;
64             use Scalar::Util ('reftype');
65             # Simpliest possible service:
66             # - reflect/echo 'params' (of request) to 'result' (of response)
67             # - Framework will take care of request parsing and response serialization
68             # - On validation errors, Framework will turn a Perl exception to a JSON-RPC fault.
69             # Call this by: ..., "method": "Test.echo", ...
70             sub echo {
71             my ($p, $jrpc) = @_;
72             # Validate, require $p to be HASH (ref).
73             # Framework will convert exceptions to JSON-RPC Fault
74             if (reftype($p) ne 'HASH') {die("param was not found to be a JSON Object");}
75             return($p);
76             }
77             1;
78              
79              
80             =cut
81              
82             # Could do Storable::dclone($p) to be on paranoid side
83              
84             sub handle_cgi {
85 0     0 1   my ($cgi) = @_;
86            
87             # Early mime output
88             # TODO: Also Include length ...must be later
89             # DEBUG: print("Extra: Math-$Math::VERSION\r\n");
90 0           print("Content-type: $mimetype\r\n"); # .termheaders()
91 0           my $jresp = {'id' => $naid, 'jsonrpc' => '2.0', }; # Set up dummy
92 0           my $buffer = $cgi->param('POSTDATA'); # POST Body
93 0           my $j;
94             # EVAL ...
95 0           eval {
96 0 0         if (!$buffer) {die("JSON-RPC Request body is Empty (-32700)");}
  0            
97             #my $req = eval { JSON::XS::decode_json($jstext); };
98 0           $j = eval { JRPC::parse($buffer); };
  0            
99 0 0         if ($@) {die("Error Parsing Request: $@");}
  0            
100 0 0 0       if (defined($JRPC::prelogger) && (ref($JRPC::prelogger) eq 'CODE')) {$JRPC::prelogger->($j);}
  0            
101 0           my $p = $j->{'params'};
102 0           my $m = $j->{'method'};
103 0           $jresp->{'id'} = $j->{'id'};
104 0           my $f; # Below: Support both plain-method and dot-notation dispatching.
105 0           my $mid = 0;
106             # TODO: index($m, '.') > 0 # Faster than regex ?
107 0 0         if ($m =~ /\./) {$f = JRPC::methresolve_dotnot($cgi, $m);$mid=1;}
  0            
  0            
  0            
108             else {$f = JRPC::methresolve($cgi, $m);} #
109 0 0         if (!$f) {die("method '$m' not resolved (-32601) mid=$mid");}
  0            
110             ##### reqinit
111             #if (my $f = $pkg->can('reqinit')) {$f->($p, $j);}
112             # Execute
113 0           my $res = eval { $f->($p); }; # Dispatch (catching any exceptions)
  0            
114 0 0         if ($@) {die("Error in processing JSON-RPC method '$m' (-32603): $@");}
  0            
115             # Definite Success - serialize response ?
116 0           $jresp->{'result'} = $res;
117             # Output
118 0           my $out = eval { encode_json($jresp); }; # Serialize as a separate step to know length
  0            
119 0 0         if ($@) {die("Error Forming the JSON-RPC result response: $@");}
  0            
120             # $hdrs_out->{'content-length'} = length($out); # TODO:
121            
122             # Late headers ?
123 0           print(termheaders(length($out)).$out);
124             }; # End processing eval
125             # Formulate a fault
126             # Problem: any output here gets duplicated (literal or function generated).
127             # Info: Service package was missing use strict; use warnings;. Was suing wrong var for forked child PID
128             # $pid instead of $cpid, so was getting wrong info for fork() success. fork() process duplication
129             # seemed to cause output duplication as STDIN,STDOUT were not yet successfully closed.
130             # handle async processing by fork() with care !
131 0 0         if ($@) {
132 0           my $fault = JRPC::createfault($j, $@, 500);
133             #DEBUG:open(my $fh, ">>", "/tmp/jrpc.$$.out");
134             #DEBUG:print($fh "\n=====\n$fault\n=====\n");
135             #DEBUG:close($fh);
136 0           print(termheaders(length($fault)).$fault);
137             #TEST:print("{}");
138             }
139             #return(0);
140             }
141              
142             # Helper sub to terminate HTTP headers with content length passed/
143             sub termheaders {
144 0 0   0 0   if ($_[0]) {return("Content-length: $_[0]\r\n\r\n");}
  0            
145 0           return "\r\n";
146             #"";
147             }
148             # TODO: Overload for both signatures:
149             # - ($cgi)
150             # - (HTTP::Server::Simple::CGI, $CGI)
151              
152             =head2 JRPC::CGI::handle_simple_server_cgi($server, $cgi);
153              
154             Wrapper for intercepting a request to HTTP::Server::Simple::CGI.
155             Alias this as a handle_request() in your package implementing
156             HTTP::Server::Simple::CGI. Example:
157              
158             #!/usr/bin/perl
159             {
160             package MyJRPC;
161             use HTTP::Server::Simple::CGI;
162             use base 'HTTP::Server::Simple::CGI';
163             # Reuse handle_simple_server_cgi, assign as local alias.
164             *handle_request = \&JRPC::CGI::handle_simple_server_cgi;
165             }
166             my $port = $ENV{'HTTP_SIMPLE_PORT'} || 8080;
167             my $pid = MyWebServer->new($port);
168             #my $pid = MyWebServer->new($port)->background();
169            
170             print "Use 'kill $pid' to stop server (on port $port).\n";
171              
172             =head1 RUNNING SERVER IN THREAD
173              
174             To be able to run server in thread and to be able to terminate the thread, use the following idiom:
175              
176             # Server thread as anonymous sub. Pass port to run at.
177             my $runmyserver = sub {
178             my ($port) = @_;
179             # Use signaling to kill thread
180             $SIG{'KILL'} = sub { threads->exit(); };
181             # Run in the same process, NOT spawning a sub process.
182             MyServer->new($port)->run();
183             };
184            
185             my $thr = threads->create($runmyserver, $port);
186             # ...
187             # Much later ... terminate server as no more needed.
188             $thr->kill('KILL')->detach();
189             # This main thread should continue / survive beyond this point ...
190              
191             =head1 HINTS
192              
193             JSON-RPC is not a domain for obsessed print(); debugging folks. Printing to STDOUT messes up the JSON-RPC response output.
194             The returned data structure gets automatically converted to a successful JSON-RPC Response (data goes into 'result' member).
195             Any fatal errors thrown as Perl exceptions get automatically converted to a valid JSON-RPC exception / fault
196             (member 'error', and optionally to logs).
197             Any diagnostic messaging goes to response or logs (or both), NOT STDOUT.
198              
199             =head1 TODO
200              
201             =over 4
202              
203             =item * Private package (file) for ServerSimple (with direct default handler handle_request())?
204              
205             =item * In private package use HTTP::Server::Simple::CGI (and inherit from it)
206              
207             =back
208              
209             =cut
210             #use JRPC::CGI; # To have the uri() method
211             # NOTE REQUEST_URI (or PATH_INFO) contains
212             our $haveuri = 0;
213             # For testing purposes ONLY.
214             # Note: These should reside in context of serv. pkg. or $server (see below).
215             # Need a nice accessor for this: Pkg->dieaftercnt(3) (Inherit)
216             our $dieaftercnt = 0;
217             our $reqcnt = 0;
218             # sub CGI::uri {return $ENV{'REQUEST_URI'};}
219             sub handle_simple_server_cgi {
220 0     0 1   my ($server, $cgi) = @_;
221 0 0         if (!$haveuri) {
222             #no strict ('subs');
223 0           eval("sub CGI::uri {return \$ENV{'REQUEST_URI'};}");
224 0           $haveuri++;
225             }
226            
227 0 0         if ($cgi->request_method() ne 'POST') {
228 0           print("HTTP/1.0 500 Must Send a POST\r\nContent-type: text/plain\r\n\r\nNeed to POST-the-JSON");return;
  0            
229             }
230             # Too early to say ? It's okay, the message (result/error) will tell the outcome.
231             # We trust in server catching every exception and turning it into error.
232 0           print("HTTP/1.0 200 OK\r\n");
233             # Use Standard handle_cgi() for the rest
234 0           handle_cgi($cgi);
235             # TODO: Move this to be package specific
236             #$reqcnt++;
237             #DEBUG:print(STDERR "CNT: $reqcnt, vs. $dieaftercnt\n");
238             #threads->exit(); # This works
239             #print("PASSED\n");
240             #if ($dieaftercnt && ($reqcnt >= $dieaftercnt)) {
241             # #sleep(3);
242             # my $thr;
243             # my $can = threads->can('exit');
244             # DEBUG:print(STDERR "Count full, ready to term (threads: $threads::VERSION) $can\n");
245             # # TODO: Initial Problem - thread does not exit like wanted. It _does_ exit, but join() does not happen!!!
246             # $thr = threads->self();
247             # #$thr->exit();
248             # threads->exit();
249             # print(STDERR "Passed threads->exit() thr=$thr\n"); #
250             #}
251             }
252             1;