File Coverage

blib/lib/Lim/RPC/Protocol/JSONRPC2.pm
Criterion Covered Total %
statement 64 97 65.9
branch 10 36 27.7
condition 8 27 29.6
subroutine 15 16 93.7
pod 5 5 100.0
total 102 181 56.3


line stmt bran cond sub pod time code
1             package Lim::RPC::Protocol::JSONRPC2;
2              
3 3     3   6726 use common::sense;
  3         8  
  3         33  
4              
5 3     3   208 use Scalar::Util qw(blessed weaken);
  3         7  
  3         265  
6              
7 3     3   18 use HTTP::Status qw(:constants);
  3         7  
  3         3134  
8 3     3   26 use HTTP::Request ();
  3         6  
  3         63  
9 3     3   18 use HTTP::Response ();
  3         6  
  3         74  
10 3     3   17 use JSON::XS ();
  3         8  
  3         54  
11              
12 3     3   18 use Lim ();
  3         11  
  3         57  
13 3     3   18 use Lim::RPC::Callback ();
  3         5  
  3         76  
14              
15 3     3   16 use base qw(Lim::RPC::Protocol);
  3         6  
  3         41601  
16              
17             =encoding utf8
18              
19             =head1 NAME
20              
21             ...
22              
23             =head1 VERSION
24              
25             See L for version.
26              
27             =cut
28              
29             our $VERSION = $Lim::VERSION;
30             our $JSON = JSON::XS->new->ascii->convert_blessed;
31              
32             =head1 SYNOPSIS
33              
34             ...
35              
36             =head1 SUBROUTINES/METHODS
37              
38             =head2 Init
39              
40             =cut
41              
42 1     1 1 4 sub Init {
43             }
44              
45             =head2 Destroy
46              
47             =cut
48              
49 1     1 1 3 sub Destroy {
50             }
51              
52             =head2 name
53              
54             =cut
55              
56             sub name {
57 5     5 1 29 'jsonrpc2';
58             }
59              
60             =head2 serve
61              
62             =cut
63              
64 1     1 1 8 sub serve {
65             }
66              
67             =head2 handle
68              
69             =cut
70              
71             sub handle {
72 1     1 1 5 my ($self, $cb, $request, $transport) = @_;
73            
74 1 50 33     26 unless (blessed($request) and $request->isa('HTTP::Request')) {
75 0         0 return;
76             }
77              
78 1 50 33     10 if ($request->header('Content-Type') =~ /(?:^|\s)application\/json(?:$|\s|;)/o and $request->uri =~ /^\/([a-zA-Z]+)\s*$/o) {
79 1         106 my ($module) = ($1);
80 1         32 my $response = HTTP::Response->new;
81 1         146 $response->request($request);
82 1         16 $response->protocol($request->protocol);
83            
84 1         22 $module = lc($module);
85 1         15 my $server = $self->server;
86 1 50 33     25 if (defined $server and $server->have_module($module)) {
87 1         3 my ($jsonreq, $jsonresp);
88            
89 1         3 eval {
90 1         7 $jsonreq = $JSON->decode($request->content);
91             };
92 1 50       52 unless ($@) {
93 1 50 33     36 if (ref($jsonreq) eq 'HASH' and exists $jsonreq->{jsonrpc} and exists $jsonreq->{id} and exists $jsonreq->{method} and $jsonreq->{jsonrpc} eq '2.0') {
      33        
      33        
      33        
94 1         8 my $id = $jsonreq->{id};
95 1         5 my $call = $jsonreq->{method};
96            
97 1 50       10 if ($server->have_module_call($module, $call)) {
98 1         5 my $obj = $server->module_obj_by_protocol($module, $self->name);
99 1         4 my $real_self = $self;
100 1         7 weaken($self);
101            
102             $obj->$call(Lim::RPC::Callback->new(
103             cb => sub {
104 1     1   3 my ($result) = @_;
105            
106 1 50       5 unless (defined $self) {
107 0         0 return;
108             }
109            
110 1 50 33     10 if (blessed $result and $result->isa('Lim::Error')) {
    50          
111 0         0 $response->code($result->code);
112 0         0 eval {
113 0         0 $response->content($JSON->encode({
114             jsonrpc => '2.0',
115             error => {
116             code => $result->code,
117             message => $result->message
118             },
119             id => $id
120             }));
121             };
122 0 0       0 if ($@) {
123 0         0 $response->code(HTTP_INTERNAL_SERVER_ERROR);
124 0 0       0 Lim::WARN and $self->{logger}->warn('JSON encode error: ', $@);
125             }
126             else {
127 0         0 $response->header(
128             'Content-Type' => 'application/json; charset=utf-8',
129             'Cache-Control' => 'no-cache',
130             'Pragma' => 'no-cache'
131             );
132             }
133             }
134             elsif (ref($result) eq 'HASH') {
135 1         3 eval {
136 1         45 $response->content($JSON->encode({
137             jsonrpc => '2.0',
138             result => $result,
139             id => $id
140             }));
141             };
142 1 50       29 if ($@) {
143 0         0 $response->code(HTTP_INTERNAL_SERVER_ERROR);
144 0 0       0 Lim::WARN and $self->{logger}->warn('JSON encode error: ', $@);
145             }
146             else {
147 1         7 $response->header(
148             'Content-Type' => 'application/json; charset=utf-8',
149             'Cache-Control' => 'no-cache',
150             'Pragma' => 'no-cache'
151             );
152 1         130 $response->code(HTTP_OK);
153             }
154             }
155             else {
156 0         0 $response->code(HTTP_INTERNAL_SERVER_ERROR);
157 0         0 $self->{logger}->debug('Invalid result from JSONRPC call ', $call);
158             }
159            
160 1         16 $cb->cb->($response);
161 1         5 return;
162             },
163             reset_timeout => sub {
164 0     0   0 $cb->reset_timeout;
165 1         14 }), $jsonreq->{params});
166 1         10 return 1;
167             }
168             else {
169 0           $response->code(HTTP_NOT_FOUND);
170 0           $jsonresp = {
171             jsonrpc => '2.0',
172             error => {
173             code => -32601,
174             message => 'Method not found'
175             },
176             id => $id
177             };
178             }
179             }
180             else {
181 0           $response->code(HTTP_BAD_REQUEST);
182 0           $jsonresp = {
183             jsonrpc => '2.0',
184             error => {
185             code => -32600,
186             message => 'Invalid Request'
187             },
188             id => undef
189             };
190             }
191             }
192 0 0 0       if ($@ and !defined $jsonresp) {
193 0           $response->code(HTTP_INTERNAL_SERVER_ERROR);
194 0           $jsonresp = {
195             jsonrpc => '2.0',
196             error => {
197             code => -32700,
198             message => 'Parse error'
199             },
200             id => undef
201             };
202             }
203 0 0         if (defined $jsonresp) {
    0          
204 0           eval {
205 0           $response->content($JSON->encode($jsonresp));
206             };
207 0 0         if ($@) {
208 0           $response->code(HTTP_INTERNAL_SERVER_ERROR);
209 0 0         Lim::WARN and $self->{logger}->warn('JSON encode error: ', $@);
210             }
211             }
212             elsif (!$response->code) {
213 0           $response->code(HTTP_INTERNAL_SERVER_ERROR);
214 0           $self->{logger}->debug('Unknown response, setting HTTP_INTERNAL_SERVER_ERROR');
215             }
216             }
217             else {
218 0           return;
219             }
220              
221 0           $cb->cb->($response);
222 0           return 1;
223             }
224 0           return;
225             }
226              
227             =head1 AUTHOR
228              
229             Jerry Lundström, C<< >>
230              
231             =head1 BUGS
232              
233             Please report any bugs or feature requests to L.
234              
235             =head1 SUPPORT
236              
237             You can find documentation for this module with the perldoc command.
238              
239             perldoc Lim
240              
241             You can also look for information at:
242              
243             =over 4
244              
245             =item * Lim issue tracker (report bugs here)
246              
247             L
248              
249             =back
250              
251             =head1 ACKNOWLEDGEMENTS
252              
253             =head1 LICENSE AND COPYRIGHT
254              
255             Copyright 2012-2013 Jerry Lundström.
256              
257             This program is free software; you can redistribute it and/or modify it
258             under the terms of either: the GNU General Public License as published
259             by the Free Software Foundation; or the Artistic License.
260              
261             See http://dev.perl.org/licenses/ for more information.
262              
263              
264             =cut
265              
266             1; # End of Lim::RPC::Protocol::JSONRPC2