File: | blib/lib/OpenSRF/Application.pm |
Coverage: | 19.1% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package OpenSRF::Application; | ||||||
2 | # vim:noet:ts=4 | ||||||
3 | 9 9 9 | 50 41 65 | use vars qw/$_app $log @_METHODS $thunk $server_class/; | ||||
4 | |||||||
5 | 9 9 9 | 59 33 61 | use base qw/OpenSRF/; | ||||
6 | 9 9 9 | 76 35 73 | use OpenSRF::AppSession; | ||||
7 | 9 9 9 | 67 32 78 | use OpenSRF::DomainObject::oilsMethod; | ||||
8 | 9 9 9 | 65 36 66 | use OpenSRF::DomainObject::oilsResponse qw/:status/; | ||||
9 | 9 9 9 | 62 35 59 | use OpenSRF::Utils::Logger qw/:level $logger/; | ||||
10 | 9 9 9 | 66 42 88 | use Data::Dumper; | ||||
11 | 9 9 9 | 72 31 65 | use Time::HiRes qw/time/; | ||||
12 | 9 9 9 | 71 36 59 | use OpenSRF::EX qw/:try/; | ||||
13 | 9 9 9 | 61 37 73 | use Carp; | ||||
14 | 9 9 9 | 66 41 57 | use OpenSRF::Utils::JSON; | ||||
15 | #use OpenSRF::UnixServer; # to get the server class from UnixServer::App | ||||||
16 | |||||||
17 | 0 | 0 | sub DESTROY{}; | ||||
18 | |||||||
19 | 9 9 9 | 60 35 60 | use strict; | ||||
20 | 9 9 9 | 64 41 61 | use warnings; | ||||
21 | |||||||
22 | $log = 'OpenSRF::Utils::Logger'; | ||||||
23 | |||||||
24 | our $in_request = 0; | ||||||
25 | our @pending_requests; | ||||||
26 | |||||||
27 | sub package { | ||||||
28 | 0 | 0 | 0 | my $self = shift; | |||
29 | 0 | 0 | return 1 unless ref($self); | ||||
30 | 0 | 0 | return $self->{package}; | ||||
31 | } | ||||||
32 | |||||||
33 | sub signature { | ||||||
34 | 0 | 0 | 0 | my $self = shift; | |||
35 | 0 | 0 | return 0 unless ref($self); | ||||
36 | 0 | 0 | return $self->{signature}; | ||||
37 | } | ||||||
38 | |||||||
39 | sub strict { | ||||||
40 | 0 | 0 | 0 | my $self = shift; | |||
41 | 0 | 0 | return 0 unless ref($self); | ||||
42 | 0 | 0 | return $self->{strict}; | ||||
43 | } | ||||||
44 | |||||||
45 | sub argc { | ||||||
46 | 0 | 0 | 0 | my $self = shift; | |||
47 | 0 | 0 | return 0 unless ref($self); | ||||
48 | 0 | 0 | return $self->{argc}; | ||||
49 | } | ||||||
50 | |||||||
51 | sub api_name { | ||||||
52 | 0 | 0 | 0 | my $self = shift; | |||
53 | 0 | 0 | return 1 unless ref($self); | ||||
54 | 0 | 0 | return $self->{api_name}; | ||||
55 | } | ||||||
56 | |||||||
57 | sub api_level { | ||||||
58 | 0 | 0 | 0 | my $self = shift; | |||
59 | 0 | 0 | return 1 unless ref($self); | ||||
60 | 0 | 0 | return $self->{api_level}; | ||||
61 | } | ||||||
62 | |||||||
63 | sub session { | ||||||
64 | 0 | 0 | 0 | my $self = shift; | |||
65 | 0 | 0 | my $session = shift; | ||||
66 | |||||||
67 | 0 | 0 | if($session) { | ||||
68 | 0 | 0 | $self->{session} = $session; | ||||
69 | } | ||||||
70 | 0 | 0 | return $self->{session}; | ||||
71 | } | ||||||
72 | |||||||
73 | sub server_class { | ||||||
74 | 91 | 0 | 297 | my $class = shift; | |||
75 | 91 | 326 | if($class) { | ||||
76 | 0 | 0 | $server_class = $class; | ||||
77 | } | ||||||
78 | 91 | 384 | return $server_class; | ||||
79 | } | ||||||
80 | |||||||
81 | sub thunk { | ||||||
82 | 0 | 0 | 0 | my $self = shift; | |||
83 | 0 | 0 | my $flag = shift; | ||||
84 | 0 | 0 | $thunk = $flag if (defined $flag); | ||||
85 | 0 | 0 | return $thunk; | ||||
86 | } | ||||||
87 | |||||||
88 | sub application_implementation { | ||||||
89 | 0 | 0 | 0 | my $self = shift; | |||
90 | 0 | 0 | my $app = shift; | ||||
91 | |||||||
92 | 0 | 0 | if (defined $app) { | ||||
93 | 0 | 0 | $_app = $app; | ||||
94 | 0 | 0 | $_app->use; | ||||
95 | 0 | 0 | if( $@ ) { | ||||
96 | 0 | 0 | $log->error( "Error loading application_implementation: $app -> $@", ERROR); | ||||
97 | } | ||||||
98 | |||||||
99 | } | ||||||
100 | |||||||
101 | 0 | 0 | return $_app; | ||||
102 | } | ||||||
103 | |||||||
104 | sub handler { | ||||||
105 | 0 | 0 | 0 | my ($self, $session, $app_msg) = @_; | |||
106 | |||||||
107 | 0 | 0 | if( ! $app_msg ) { | ||||
108 | 0 | 0 | return 1; # error? | ||||
109 | } | ||||||
110 | |||||||
111 | 0 | 0 | my $app = $self->application_implementation; | ||||
112 | |||||||
113 | 0 | 0 | if ($session->last_message_type eq 'REQUEST') { | ||||
114 | |||||||
115 | 0 | 0 | my @p = $app_msg->params; | ||||
116 | 0 | 0 | my $method_name = $app_msg->method; | ||||
117 | 0 | 0 | my $method_proto = $session->last_message_api_level; | ||||
118 | 0 | 0 | $log->info("CALL: $method_name [". (@p ? join(', ',@p) : '') ."]"); | ||||
119 | |||||||
120 | 0 | 0 | my $coderef = $app->method_lookup( $method_name, $method_proto, 1, 1 ); | ||||
121 | |||||||
122 | 0 | 0 | unless ($coderef) { | ||||
123 | 0 | 0 | $session->status( OpenSRF::DomainObject::oilsMethodException->new( | ||||
124 | statusCode => STATUS_NOTFOUND(), | ||||||
125 | status => "Method [$method_name] not found for $app")); | ||||||
126 | 0 | 0 | return 1; | ||||
127 | } | ||||||
128 | |||||||
129 | 0 | 0 | unless ($session->continue_request) { | ||||
130 | 0 | 0 | $session->status( | ||||
131 | OpenSRF::DomainObject::oilsConnectStatus->new( | ||||||
132 | statusCode => STATUS_REDIRECTED(), | ||||||
133 | status => 'Disconnect on max requests' ) ); | ||||||
134 | 0 | 0 | $session->kill_me; | ||||
135 | 0 | 0 | return 1; | ||||
136 | } | ||||||
137 | |||||||
138 | 0 | 0 | if (ref $coderef) { | ||||
139 | 0 | 0 | my @args = $app_msg->params; | ||||
140 | 0 | 0 | my $appreq = OpenSRF::AppRequest->new( $session ); | ||||
141 | |||||||
142 | 0 | 0 | $log->debug( "in_request = $in_request : [" . $appreq->threadTrace."]", INTERNAL ); | ||||
143 | 0 | 0 | if( $in_request ) { | ||||
144 | 0 | 0 | $log->debug( "Pushing onto pending requests: " . $appreq->threadTrace, DEBUG ); | ||||
145 | 0 | 0 | push @pending_requests, [ $appreq, \@args, $coderef ]; | ||||
146 | 0 | 0 | return 1; | ||||
147 | } | ||||||
148 | |||||||
149 | |||||||
150 | 0 | 0 | $in_request++; | ||||
151 | |||||||
152 | 0 | 0 | $log->debug( "Executing coderef for {$method_name}", INTERNAL ); | ||||
153 | |||||||
154 | 0 | 0 | my $resp; | ||||
155 | try { | ||||||
156 | # un-if(0) this block to enable param checking based on signature and argc | ||||||
157 | 0 | 0 | if ($coderef->strict) { | ||||
158 | 0 | 0 | if (@args < $coderef->argc) { | ||||
159 | 0 | 0 | die "Not enough params passed to ". | ||||
160 | $coderef->api_name." : requires ". $coderef->argc | ||||||
161 | } | ||||||
162 | 0 | 0 | if (@args) { | ||||
163 | 0 | 0 | my $sig = $coderef->signature; | ||||
164 | 0 | 0 | if ($sig && exists $sig->{params}) { | ||||
165 | 0 0 | 0 0 | for my $p (0 .. scalar(@{ $sig->{params} }) - 1 ) { | ||||
166 | 0 | 0 | my $s = $sig->{params}->[$p]; | ||||
167 | 0 | 0 | my $a = $args[$p]; | ||||
168 | 0 | 0 | if ($s->{class} && OpenSRF::Utils::JSON->lookup_hint(ref $a) ne $s->{class}) { | ||||
169 | 0 | 0 | die "Incorrect param class at position $p : should be a '$$s{class}'"; | ||||
170 | } elsif ($s->{type}) { | ||||||
171 | 0 | 0 | if (lc($s->{type}) eq 'object' && $a !~ /HASH/o) { | ||||
172 | 0 | 0 | die "Incorrect param type at position $p : should be an 'object'"; | ||||
173 | } elsif (lc($s->{type}) eq 'array' && $a !~ /ARRAY/o) { | ||||||
174 | 0 | 0 | die "Incorrect param type at position $p : should be an 'array'"; | ||||
175 | } elsif (lc($s->{type}) eq 'number' && (ref($a) || $a !~ /^-?\d+(?:\.\d+)?$/o)) { | ||||||
176 | 0 | 0 | die "Incorrect param type at position $p : should be a 'number'"; | ||||
177 | } elsif (lc($s->{type}) eq 'string' && ref($a)) { | ||||||
178 | 0 | 0 | die "Incorrect param type at position $p : should be a 'string'"; | ||||
179 | } | ||||||
180 | } | ||||||
181 | } | ||||||
182 | } | ||||||
183 | } | ||||||
184 | } | ||||||
185 | |||||||
186 | 0 | 0 | my $start = time(); | ||||
187 | 0 | 0 | $resp = $coderef->run( $appreq, @args); | ||||
188 | 0 | 0 | my $time = sprintf '%.3f', time() - $start; | ||||
189 | |||||||
190 | 0 | 0 | $log->debug( "Method duration for [$method_name]: ". $time ); | ||||
191 | 0 | 0 | if( defined( $resp ) ) { | ||||
192 | 0 | 0 | $appreq->respond_complete( $resp ); | ||||
193 | } else { | ||||||
194 | 0 | 0 | $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new( | ||||
195 | statusCode => STATUS_COMPLETE(), | ||||||
196 | status => 'Request Complete' ) ); | ||||||
197 | } | ||||||
198 | } catch Error with { | ||||||
199 | 0 | 0 | my $e = shift; | ||||
200 | 0 | 0 | warn "Caught error from 'run' method: $e\n"; | ||||
201 | |||||||
202 | 0 | 0 | if(UNIVERSAL::isa($e,"Error")) { | ||||
203 | 0 | 0 | $e = $e->stringify(); | ||||
204 | } | ||||||
205 | 0 | 0 | my $sess_id = $session->session_id; | ||||
206 | 0 | 0 | $session->status( | ||||
207 | OpenSRF::DomainObject::oilsMethodException->new( | ||||||
208 | statusCode => STATUS_INTERNALSERVERERROR(), | ||||||
209 | status => " *** Call to [$method_name] failed for session ". | ||||||
210 | "[$sess_id], thread trace ". | ||||||
211 | "[".$appreq->threadTrace."]:\n$e\n" | ||||||
212 | ) | ||||||
213 | ); | ||||||
214 | 0 | 0 | }; | ||||
215 | |||||||
216 | |||||||
217 | |||||||
218 | # ---------------------------------------------- | ||||||
219 | |||||||
220 | |||||||
221 | # XXX may need this later | ||||||
222 | # $_->[1] = 1 for (@OpenSRF::AppSession::_CLIENT_CACHE); | ||||||
223 | |||||||
224 | 0 | 0 | $in_request--; | ||||
225 | |||||||
226 | 0 | 0 | $log->debug( "Pending Requests: " . scalar(@pending_requests), INTERNAL ); | ||||
227 | |||||||
228 | # cycle through queued requests | ||||||
229 | 0 | 0 | while( my $aref = shift @pending_requests ) { | ||||
230 | 0 | 0 | $in_request++; | ||||
231 | 0 | 0 | my $resp; | ||||
232 | try { | ||||||
233 | # un-if(0) this block to enable param checking based on signature and argc | ||||||
234 | 0 | 0 | if (0) { | ||||
235 | if (@args < $aref->[2]->argc) { | ||||||
236 | die "Not enough params passed to ". | ||||||
237 | $aref->[2]->api_name." : requires ". $aref->[2]->argc | ||||||
238 | } | ||||||
239 | if (@args) { | ||||||
240 | my $sig = $aref->[2]->signature; | ||||||
241 | if ($sig && exists $sig->{params}) { | ||||||
242 | for my $p (0 .. scalar(@{ $sig->{params} }) - 1 ) { | ||||||
243 | my $s = $sig->{params}->[$p]; | ||||||
244 | my $a = $args[$p]; | ||||||
245 | if ($s->{class} && OpenSRF::Utils::JSON->lookup_hint(ref $a) ne $s->{class}) { | ||||||
246 | die "Incorrect param class at position $p : should be a '$$s{class}'"; | ||||||
247 | } elsif ($s->{type}) { | ||||||
248 | if (lc($s->{type}) eq 'object' && $a !~ /HASH/o) { | ||||||
249 | die "Incorrect param type at position $p : should be an 'object'"; | ||||||
250 | } elsif (lc($s->{type}) eq 'array' && $a !~ /ARRAY/o) { | ||||||
251 | die "Incorrect param type at position $p : should be an 'array'"; | ||||||
252 | } elsif (lc($s->{type}) eq 'number' && (ref($a) || $a !~ /^-?\d+(?:\.\d+)?$/o)) { | ||||||
253 | die "Incorrect param type at position $p : should be a 'number'"; | ||||||
254 | } elsif (lc($s->{type}) eq 'string' && ref($a)) { | ||||||
255 | die "Incorrect param type at position $p : should be a 'string'"; | ||||||
256 | } | ||||||
257 | } | ||||||
258 | } | ||||||
259 | } | ||||||
260 | } | ||||||
261 | } | ||||||
262 | |||||||
263 | 0 | 0 | my $start = time; | ||||
264 | 0 0 | 0 0 | my $response = $aref->[2]->run( $aref->[0], @{$aref->[1]} ); | ||||
265 | 0 | 0 | my $time = sprintf '%.3f', time - $start; | ||||
266 | 0 0 | 0 0 | $log->debug( "Method duration for [".$aref->[2]->api_name." -> ".join(', ',@{$aref->[1]}).']: '.$time, DEBUG ); | ||||
267 | |||||||
268 | 0 | 0 | $appreq = $aref->[0]; | ||||
269 | 0 | 0 | if( ref( $response ) ) { | ||||
270 | 0 | 0 | $appreq->respond_complete( $response ); | ||||
271 | } else { | ||||||
272 | 0 | 0 | $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new( | ||||
273 | statusCode => STATUS_COMPLETE(), | ||||||
274 | status => 'Request Complete' ) ); | ||||||
275 | } | ||||||
276 | 0 | 0 | $log->debug( "Executed: " . $appreq->threadTrace, INTERNAL ); | ||||
277 | } catch Error with { | ||||||
278 | 0 | 0 | my $e = shift; | ||||
279 | 0 | 0 | if(UNIVERSAL::isa($e,"Error")) { | ||||
280 | 0 | 0 | $e = $e->stringify(); | ||||
281 | } | ||||||
282 | $session->status( | ||||||
283 | 0 | 0 | OpenSRF::DomainObject::oilsMethodException->new( | ||||
284 | statusCode => STATUS_INTERNALSERVERERROR(), | ||||||
285 | status => "Call to [".$aref->[2]->api_name."] faild: $e" | ||||||
286 | ) | ||||||
287 | ); | ||||||
288 | 0 | 0 | }; | ||||
289 | 0 | 0 | $in_request--; | ||||
290 | } | ||||||
291 | |||||||
292 | 0 | 0 | return 1; | ||||
293 | } | ||||||
294 | |||||||
295 | 0 | 0 | $log->info("Received non-REQUEST message in Application handler"); | ||||
296 | |||||||
297 | 0 | 0 | my $res = OpenSRF::DomainObject::oilsMethodException->new( | ||||
298 | status => "Received non-REQUEST message in Application handler"); | ||||||
299 | 0 | 0 | $session->send('ERROR', $res); | ||||
300 | 0 | 0 | $session->kill_me; | ||||
301 | 0 | 0 | return 1; | ||||
302 | |||||||
303 | } else { | ||||||
304 | 0 | 0 | $session->push_queue([ $app_msg, $session->last_threadTrace ]); | ||||
305 | } | ||||||
306 | |||||||
307 | 0 | 0 | $session->last_message_type(''); | ||||
308 | 0 | 0 | $session->last_message_api_level(''); | ||||
309 | |||||||
310 | 0 | 0 | return 1; | ||||
311 | } | ||||||
312 | |||||||
313 | sub is_registered { | ||||||
314 | 0 | 0 | 0 | my $self = shift; | |||
315 | 0 | 0 | my $api_name = shift; | ||||
316 | 0 | 0 | my $api_level = shift || 1; | ||||
317 | 0 | 0 | return exists($_METHODS[$api_level]{$api_name}); | ||||
318 | } | ||||||
319 | |||||||
320 | |||||||
321 | sub normalize_whitespace { | ||||||
322 | 29 | 0 | 106 | my $txt = shift; | |||
323 | |||||||
324 | 29 | 137 | $txt =~ s/^\s+//gso; | ||||
325 | 29 | 236 | $txt =~ s/\s+$//gso; | ||||
326 | 29 | 237 | $txt =~ s/\s+/ /gso; | ||||
327 | 29 | 106 | $txt =~ s/\n//gso; | ||||
328 | 29 | 198 | $txt =~ s/\. /\. /gso; | ||||
329 | |||||||
330 | 29 | 233 | return $txt; | ||||
331 | } | ||||||
332 | |||||||
333 | sub parse_string_signature { | ||||||
334 | 29 | 0 | 112 | my $string = shift; | |||
335 | 29 | 114 | return [] unless $string; | ||||
336 | 29 | 177 | my @chunks = split(/\@/smo, $string); | ||||
337 | |||||||
338 | 29 | 104 | my @params; | ||||
339 | 29 | 95 | my $ret; | ||||
340 | 29 | 98 | my $desc = ''; | ||||
341 | 29 | 139 | for (@chunks) { | ||||
342 | 29 | 166 | if (/^return (.+)$/so) { | ||||
343 | 0 | 0 | $ret = [normalize_whitespace($1)]; | ||||
344 | } elsif (/^param (\w+) \b(.+)$/so) { | ||||||
345 | 0 | 0 | push @params, [ $1, normalize_whitespace($2) ]; | ||||
346 | } else { | ||||||
347 | 29 | 114 | $desc .= '@' if $desc; | ||||
348 | 29 | 137 | $desc .= $_; | ||||
349 | } | ||||||
350 | } | ||||||
351 | |||||||
352 | 29 | 124 | return [normalize_whitespace($desc),\@params, $ret]; | ||||
353 | } | ||||||
354 | |||||||
355 | sub parse_array_signature { | ||||||
356 | 29 | 0 | 105 | my $array = shift; | |||
357 | 29 | 136 | my ($d,$p,$r) = @$array; | ||||
358 | 29 | 162 | return {} unless ($d or $p or $r); | ||||
359 | |||||||
360 | return { | ||||||
361 | 0 | 0 | desc => $d, | ||||
362 | params => [ | ||||||
363 | map { | ||||||
364 | 29 | 337 | { name => $$_[0], | ||||
365 | desc => $$_[1], | ||||||
366 | type => $$_[2], | ||||||
367 | class => $$_[3], | ||||||
368 | } | ||||||
369 | } @$p | ||||||
370 | ], | ||||||
371 | 'return'=> | ||||||
372 | { desc => $$r[0], | ||||||
373 | type => $$r[1], | ||||||
374 | class => $$r[2], | ||||||
375 | } | ||||||
376 | }; | ||||||
377 | } | ||||||
378 | |||||||
379 | sub register_method { | ||||||
380 | 91 | 0 | 354 | my $self = shift; | |||
381 | 91 | 662 | my $app = ref($self) || $self; | ||||
382 | 91 | 574 | my %args = @_; | ||||
383 | |||||||
384 | |||||||
385 | 91 | 352 | throw OpenSRF::DomainObject::oilsMethodException unless ($args{method}); | ||||
386 | |||||||
387 | 91 | 431 | $args{api_level} = 1 unless(defined($args{api_level})); | ||||
388 | 91 | 365 | $args{stream} ||= 0; | ||||
389 | 91 | 377 | $args{remote} ||= 0; | ||||
390 | 91 | 344 | $args{argc} ||= 0; | ||||
391 | 91 | 522 | $args{package} ||= $app; | ||||
392 | 91 | 323 | $args{server_class} = server_class(); | ||||
393 | 91 | 349 | $args{api_name} ||= $args{server_class} . '.' . $args{method}; | ||||
394 | |||||||
395 | # un-if(0) this block to enable signature parsing | ||||||
396 | 91 | 498 | if (!$args{signature}) { | ||||
397 | 55 | 363 | if ($args{notes} && !ref($args{notes})) { | ||||
398 | 29 | 129 | $args{signature} = | ||||
399 | parse_array_signature( parse_string_signature( $args{notes} ) ); | ||||||
400 | } | ||||||
401 | } elsif( !ref($args{signature}) ) { | ||||||
402 | 0 | 0 | $args{signature} = | ||||
403 | parse_array_signature( parse_string_signature( $args{signature} ) ); | ||||||
404 | } elsif( ref($args{signature}) eq 'ARRAY') { | ||||||
405 | 0 | 0 | $args{signature} = | ||||
406 | parse_array_signature( $args{signature} ); | ||||||
407 | } | ||||||
408 | |||||||
409 | 91 | 404 | unless ($args{object_hint}) { | ||||
410 | 91 | 632 | ($args{object_hint} = $args{package}) =~ s/::/_/go; | ||||
411 | } | ||||||
412 | |||||||
413 | 91 | 533 | OpenSRF::Utils::JSON->register_class_hint( name => $args{package}, hint => $args{object_hint}, type => "hash" ); | ||||
414 | |||||||
415 | 91 | 775 | $_METHODS[$args{api_level}]{$args{api_name}} = bless \%args => $app; | ||||
416 | |||||||
417 | 91 | 629 | __PACKAGE__->register_method( | ||||
418 | stream => 0, | ||||||
419 | argc => $args{argc}, | ||||||
420 | api_name => $args{api_name}.'.atomic', | ||||||
421 | method => 'make_stream_atomic', | ||||||
422 | notes => "This is a system generated method. Please see the definition for $args{api_name}", | ||||||
423 | ) if ($args{stream}); | ||||||
424 | } | ||||||
425 | |||||||
426 | sub retrieve_remote_apis { | ||||||
427 | 0 | 0 | my $method = shift; | ||||
428 | 0 | my $session = OpenSRF::AppSession->create('router'); | |||||
429 | try { | ||||||
430 | 0 | $session->connect or OpenSRF::EX::WARN->throw("Connection to router timed out"); | |||||
431 | } catch Error with { | ||||||
432 | 0 | my $e = shift; | |||||
433 | 0 | $log->debug( "Remote subrequest returned an error:\n". $e ); | |||||
434 | 0 | return undef; | |||||
435 | } finally { | ||||||
436 | 0 | return undef unless ($session->state == $session->CONNECTED); | |||||
437 | 0 | }; | |||||
438 | |||||||
439 | 0 | my $req = $session->request( 'opensrf.router.info.class.list' ); | |||||
440 | 0 | my $list = $req->recv; | |||||
441 | |||||||
442 | 0 | if( UNIVERSAL::isa($list,"Error") ) { | |||||
443 | 0 | throw $list; | |||||
444 | } | ||||||
445 | |||||||
446 | 0 | my $content = $list->content; | |||||
447 | |||||||
448 | 0 | $req->finish; | |||||
449 | 0 | $session->finish; | |||||
450 | 0 | $session->disconnect; | |||||
451 | |||||||
452 | 0 0 | my %u_list = map { ($_ => 1) } @$content; | |||||
453 | |||||||
454 | 0 | for my $class ( keys %u_list ) { | |||||
455 | 0 | next if($class eq $server_class); | |||||
456 | 0 | populate_remote_method_cache($class, $method); | |||||
457 | } | ||||||
458 | } | ||||||
459 | |||||||
460 | sub populate_remote_method_cache { | ||||||
461 | 0 | 0 | my $class = shift; | ||||
462 | 0 | my $meth = shift; | |||||
463 | |||||||
464 | 0 | my $session = OpenSRF::AppSession->create($class); | |||||
465 | try { | ||||||
466 | 0 | $session->connect or OpenSRF::EX::WARN->throw("Connection to $class timed out"); | |||||
467 | |||||||
468 | 0 | my $call = 'opensrf.system.method.all' unless (defined $meth); | |||||
469 | 0 | $call = 'opensrf.system.method' if (defined $meth); | |||||
470 | |||||||
471 | 0 | my $req = $session->request( $call, $meth ); | |||||
472 | |||||||
473 | 0 | while (my $method = $req->recv) { | |||||
474 | 0 | next if (UNIVERSAL::isa($method, 'Error')); | |||||
475 | |||||||
476 | 0 | $method = $method->content; | |||||
477 | 0 | next if ( exists($_METHODS[$$method{api_level}]) && | |||||
478 | exists($_METHODS[$$method{api_level}]{$$method{api_name}}) ); | ||||||
479 | 0 | $method->{remote} = 1; | |||||
480 | 0 | bless($method, __PACKAGE__ ); | |||||
481 | 0 | $_METHODS[$$method{api_level}]{$$method{api_name}} = $method; | |||||
482 | } | ||||||
483 | |||||||
484 | 0 | $req->finish; | |||||
485 | 0 | $session->finish; | |||||
486 | 0 | $session->disconnect; | |||||
487 | |||||||
488 | } catch Error with { | ||||||
489 | 0 | my $e = shift; | |||||
490 | 0 | $log->debug( "Remote subrequest returned an error:\n". $e ); | |||||
491 | 0 | return undef; | |||||
492 | 0 | }; | |||||
493 | } | ||||||
494 | |||||||
495 | sub method_lookup { | ||||||
496 | 0 | 0 | my $self = shift; | ||||
497 | 0 | my $method = shift; | |||||
498 | 0 | my $proto = shift; | |||||
499 | 0 | my $no_recurse = shift || 0; | |||||
500 | 0 | my $no_remote = shift || 0; | |||||
501 | |||||||
502 | # this instead of " || 1;" above to allow api_level 0 | ||||||
503 | 0 | $proto = $self->api_level unless (defined $proto); | |||||
504 | |||||||
505 | 0 | my $class = ref($self) || $self; | |||||
506 | |||||||
507 | 0 | $log->debug("Lookup of [$method] by [$class] in api_level [$proto]", DEBUG); | |||||
508 | 0 0 | $log->debug("Available methods\n\t".join("\n\t", keys %{ $_METHODS[$proto] }), INTERNAL); | |||||
509 | |||||||
510 | 0 | my $meth; | |||||
511 | 0 | if (__PACKAGE__->thunk) { | |||||
512 | 0 | for my $p ( reverse(1 .. $proto) ) { | |||||
513 | 0 | if (exists $_METHODS[$p]{$method}) { | |||||
514 | 0 | $meth = $_METHODS[$p]{$method}; | |||||
515 | } | ||||||
516 | } | ||||||
517 | } else { | ||||||
518 | 0 | if (exists $_METHODS[$proto]{$method}) { | |||||
519 | 0 | $meth = $_METHODS[$proto]{$method}; | |||||
520 | } | ||||||
521 | } | ||||||
522 | |||||||
523 | 0 | if (defined $meth) { | |||||
524 | 0 | if($no_remote and $meth->{remote}) { | |||||
525 | 0 | $log->debug("OH CRAP We're not supposed to return remote methods", WARN); | |||||
526 | 0 | return undef; | |||||
527 | } | ||||||
528 | |||||||
529 | } elsif (!$no_recurse) { | ||||||
530 | 0 | $log->debug("We didn't find [$method], asking everyone else.", DEBUG); | |||||
531 | 0 | retrieve_remote_apis($method); | |||||
532 | 0 | $meth = $self->method_lookup($method,$proto,1); | |||||
533 | } | ||||||
534 | |||||||
535 | 0 | return $meth; | |||||
536 | } | ||||||
537 | |||||||
538 | sub run { | ||||||
539 | 0 | 0 | my $self = shift; | ||||
540 | 0 | my $req = shift; | |||||
541 | |||||||
542 | 0 | my $resp; | |||||
543 | 0 | my @params = @_; | |||||
544 | |||||||
545 | 0 | if ( !UNIVERSAL::isa($req, 'OpenSRF::AppRequest') ) { | |||||
546 | 0 | $log->debug("Creating a SubRequest object", DEBUG); | |||||
547 | 0 | unshift @params, $req; | |||||
548 | 0 | $req = OpenSRF::AppSubrequest->new; | |||||
549 | 0 | $req->session( $self->session ) if ($self->session); | |||||
550 | |||||||
551 | } else { | ||||||
552 | 0 | $log->debug("This is a top level request", DEBUG); | |||||
553 | } | ||||||
554 | |||||||
555 | 0 | if (!$self->{remote}) { | |||||
556 | 0 0 | my $code = \&{$self->{package} . '::' . $self->{method}}; | |||||
557 | 0 | my $err = undef; | |||||
558 | |||||||
559 | try { | ||||||
560 | 0 | $resp = $code->($self, $req, @params); | |||||
561 | |||||||
562 | } catch Error with { | ||||||
563 | 0 | $err = shift; | |||||
564 | |||||||
565 | 0 | if( ref($self) eq 'HASH') { | |||||
566 | 0 | $log->error("Sub $$self{package}::$$self{method} DIED!!!\n\t$err\n", ERROR); | |||||
567 | } | ||||||
568 | 0 | }; | |||||
569 | |||||||
570 | 0 | if($err) { | |||||
571 | 0 | if(UNIVERSAL::isa($err,"Error")) { | |||||
572 | 0 | throw $err; | |||||
573 | } else { | ||||||
574 | 0 | die $err->stringify; | |||||
575 | } | ||||||
576 | } | ||||||
577 | |||||||
578 | |||||||
579 | 0 | $log->debug("Coderef for [$$self{package}::$$self{method}] has been run", DEBUG); | |||||
580 | |||||||
581 | 0 | if ( ref($req) and UNIVERSAL::isa($req, 'OpenSRF::AppSubrequest') ) { | |||||
582 | 0 | $req->respond($resp) if (defined $resp); | |||||
583 | 0 | $log->debug("SubRequest object is responding with : " . join(" ",$req->responses), DEBUG); | |||||
584 | 0 | return $req->responses; | |||||
585 | } else { | ||||||
586 | 0 | $log->debug("A top level Request object is responding $resp", DEBUG) if (defined $resp); | |||||
587 | 0 | return $resp; | |||||
588 | } | ||||||
589 | } else { | ||||||
590 | 0 | my $session = OpenSRF::AppSession->create($self->{server_class}); | |||||
591 | try { | ||||||
592 | #$session->connect or OpenSRF::EX::WARN->throw("Connection to [$$self{server_class}] timed out"); | ||||||
593 | 0 | my $remote_req = $session->request( $self->{api_name}, @params ); | |||||
594 | 0 | while (my $remote_resp = $remote_req->recv) { | |||||
595 | 0 | OpenSRF::Utils::Logger->debug("Remote Subrequest Received " . $remote_resp, INTERNAL ); | |||||
596 | 0 | if( UNIVERSAL::isa($remote_resp,"Error") ) { | |||||
597 | 0 | throw $remote_resp; | |||||
598 | } | ||||||
599 | 0 | $req->respond( $remote_resp->content ); | |||||
600 | } | ||||||
601 | 0 | $remote_req->finish(); | |||||
602 | |||||||
603 | } catch Error with { | ||||||
604 | 0 | my $e = shift; | |||||
605 | 0 | $log->debug( "Remote subrequest returned an error:\n". $e ); | |||||
606 | 0 | return undef; | |||||
607 | 0 | }; | |||||
608 | |||||||
609 | 0 | if ($session) { | |||||
610 | 0 | $session->disconnect(); | |||||
611 | 0 | $session->finish(); | |||||
612 | } | ||||||
613 | |||||||
614 | 0 | $log->debug( "Remote Subrequest Responses " . join(" ", $req->responses), INTERNAL ); | |||||
615 | |||||||
616 | 0 | return $req->responses; | |||||
617 | } | ||||||
618 | # huh? how'd we get here... | ||||||
619 | 0 | return undef; | |||||
620 | } | ||||||
621 | |||||||
622 | sub introspect { | ||||||
623 | 0 | 0 | my $self = shift; | ||||
624 | 0 | my $client = shift; | |||||
625 | 0 | my $method = shift; | |||||
626 | 0 | my $limit = shift; | |||||
627 | 0 | my $offset = shift; | |||||
628 | |||||||
629 | 0 | if ($self->api_name =~ /all$/o) { | |||||
630 | 0 | $offset = $limit; | |||||
631 | 0 | $limit = $method; | |||||
632 | 0 | $method = undef; | |||||
633 | } | ||||||
634 | |||||||
635 | 0 | my ($seen,$returned) = (0,0); | |||||
636 | 0 | for my $api_level ( reverse(1 .. $#_METHODS) ) { | |||||
637 | 0 0 | for my $api_name ( sort keys %{$_METHODS[$api_level]} ) { | |||||
638 | 0 | if (!$offset || $offset <= $seen) { | |||||
639 | 0 | if (!$_METHODS[$api_level]{$api_name}{remote}) { | |||||
640 | 0 | if (defined($method)) { | |||||
641 | 0 | if ($api_name =~ $method) { | |||||
642 | 0 | if (!$limit || $returned < $limit) { | |||||
643 | 0 | $client->respond( $_METHODS[$api_level]{$api_name} ); | |||||
644 | 0 | $returned++; | |||||
645 | } | ||||||
646 | } | ||||||
647 | } else { | ||||||
648 | 0 | if (!$limit || $returned < $limit) { | |||||
649 | 0 | $client->respond( $_METHODS[$api_level]{$api_name} ); | |||||
650 | 0 | $returned++; | |||||
651 | } | ||||||
652 | } | ||||||
653 | } | ||||||
654 | } | ||||||
655 | 0 | $seen++; | |||||
656 | } | ||||||
657 | } | ||||||
658 | |||||||
659 | 0 | return undef; | |||||
660 | } | ||||||
661 | __PACKAGE__->register_method( | ||||||
662 | stream => 1, | ||||||
663 | method => 'introspect', | ||||||
664 | api_name => 'opensrf.system.method.all', | ||||||
665 | argc => 0, | ||||||
666 | signature => { | ||||||
667 | desc => q/This method is used to introspect an entire OpenSRF Application/, | ||||||
668 | return => { | ||||||
669 | desc => q/A stream of objects describing the methods available via this OpenSRF Application/, | ||||||
670 | type => 'object' | ||||||
671 | } | ||||||
672 | }, | ||||||
673 | ); | ||||||
674 | __PACKAGE__->register_method( | ||||||
675 | stream => 1, | ||||||
676 | method => 'introspect', | ||||||
677 | argc => 1, | ||||||
678 | api_name => 'opensrf.system.method', | ||||||
679 | argc => 1, | ||||||
680 | signature => { | ||||||
681 | desc => q/Use this method to get the definition of a single OpenSRF Method/, | ||||||
682 | params => [ | ||||||
683 | { desc => q/The method to introspect/, | ||||||
684 | type => 'string' }, | ||||||
685 | ], | ||||||
686 | return => { desc => q/An object describing the method requested, or an error if it can't be found/, | ||||||
687 | type => 'object' } | ||||||
688 | }, | ||||||
689 | ); | ||||||
690 | |||||||
691 | sub echo_method { | ||||||
692 | 0 | 0 | my $self = shift; | ||||
693 | 0 | my $client = shift; | |||||
694 | 0 | my @args = @_; | |||||
695 | |||||||
696 | 0 0 | $client->respond( $_ ) for (@args); | |||||
697 | 0 | return undef; | |||||
698 | } | ||||||
699 | __PACKAGE__->register_method( | ||||||
700 | stream => 1, | ||||||
701 | method => 'echo_method', | ||||||
702 | argc => 1, | ||||||
703 | api_name => 'opensrf.system.echo', | ||||||
704 | signature => { | ||||||
705 | desc => q/A test method that will echo back it's arguments in a streaming response/, | ||||||
706 | params => [ | ||||||
707 | { desc => q/One or more arguments to echo back/ } | ||||||
708 | ], | ||||||
709 | return => { desc => q/A stream of the arguments passed/ } | ||||||
710 | }, | ||||||
711 | ); | ||||||
712 | |||||||
713 | sub time_method { | ||||||
714 | 0 | 0 | my( $self, $conn ) = @_; | ||||
715 | 0 | return CORE::time; | |||||
716 | } | ||||||
717 | __PACKAGE__->register_method( | ||||||
718 | method => 'time_method', | ||||||
719 | argc => 0, | ||||||
720 | api_name => 'opensrf.system.time', | ||||||
721 | signature => { | ||||||
722 | desc => q/Returns the current system time as epoch seconds/, | ||||||
723 | return => { desc => q/epoch seconds/ } | ||||||
724 | } | ||||||
725 | ); | ||||||
726 | |||||||
727 | sub make_stream_atomic { | ||||||
728 | 0 | 0 | my $self = shift; | ||||
729 | 0 | my $req = shift; | |||||
730 | 0 | my @args = @_; | |||||
731 | |||||||
732 | 0 | (my $m_name = $self->api_name) =~ s/\.atomic$//o; | |||||
733 | 0 | my $m = $self->method_lookup($m_name); | |||||
734 | |||||||
735 | 0 | $m->session( $req->session ); | |||||
736 | 0 | my @results = $m->run(@args); | |||||
737 | 0 | $m->session(''); | |||||
738 | |||||||
739 | 0 | return \@results; | |||||
740 | } | ||||||
741 | |||||||
742 | |||||||
743 | 1; | ||||||
744 | |||||||
745 |