OpenSRF/src/perlmods/OpenSRF/Application.pm

   1 package OpenSRF::Application;
   2 use base qw/OpenSRF/;
   3 use OpenSRF::AppSession;
   4 use OpenSRF::DomainObject::oilsMethod;
   5 use OpenSRF::DomainObject::oilsResponse qw/:status/;
   6 use OpenSRF::Utils::Logger qw/:level/;
   7 use Data::Dumper;
   8 use Time::HiRes qw/time/;
   9 use vars qw/$_app $log %_METHODS/;
  10 use OpenSRF::EX qw/:try/;
  11 use strict;
  12 use warnings;
  13
  14 $log = 'OpenSRF::Utils::Logger';
  15
  16 our $in_request = 0;
  17 our @pending_requests;
  18
  19 sub application_implementation {
  20         my $self = shift;
  21         my $app = shift;
  22
  23         if (defined $app) {
  24                 $_app = $app;
  25                 eval "use $_app;";
  26                 if( $@ ) {
  27                         $log->error( "Error loading application_implementation: $app -> $@", ERROR);
  28                 }
  29
  30         }
  31
  32         return $_app;
  33 }
  34
  35 sub handler {
  36         my ($self, $session, $app_msg) = @_;
  37
  38         if( ! $app_msg ) {
  39                 return 0;  # error?
  40         }
  41
  42         $log->debug( "In Application::handler()", DEBUG );
  43
  44         my $app = $self->application_implementation;
  45
  46         if( $app ) {
  47                 $log->debug( "Application is $app", DEBUG);
  48         }
  49         $log->debug( "Message is ".$app_msg->toString(1), INTERNAL);
  50
  51
  52         if ($session->last_message_type eq 'REQUEST') {
  53                 $log->debug( "We got a REQUEST: ". $app_msg->method, INFO );
  54
  55                 my $method_name = $app_msg->method;
  56                 $log->debug( " * Looking up $method_name inside $app", DEBUG);
  57
  58                 my $method_proto = $session->last_message_protocol;
  59                 $log->debug( " * Method API Level [$method_proto]", DEBUG);
  60
  61                 my $coderef = $app->method_lookup( $method_name, $method_proto );
  62
  63                 unless ($coderef) {
  64                         $session->status( OpenSRF::DomainObject::oilsMethodException->new() );
  65                         return 1;
  66                 }
  67
  68                 $log->debug( " (we got coderef $coderef", DEBUG);
  69
  70                 unless ($session->continue_request) {
  71                         $session->status(
  72                                 OpenSRF::DomainObject::oilsConnectStatus->new(
  73                                                 statusCode => STATUS_REDIRECTED(),
  74                                                 status => 'Disconnect on max requests' ) );
  75                         $session->kill_me;
  76                         return 1;
  77                 }
  78
  79                 if (ref $coderef) {
  80                         my @args = $app_msg->params;
  81                         my $appreq = OpenSRF::AppRequest->new( $session );
  82
  83                         $log->debug( "in_request = $in_request : [" . $appreq->threadTrace."]", DEBUG );
  84                         if( $in_request ) {
  85                                 $log->debug( "Pushing onto pending requests: " . $appreq->threadTrace, DEBUG );
  86                                 push @pending_requests, [ $appreq, \@args, $coderef ];
  87                                 return 1;
  88                         }
  89
  90
  91                         $in_request++;
  92
  93                         $log->debug( "Executing coderef for {$method_name -> ".join(', ', @args)."}", INTERNAL );
  94
  95                         my $resp;
  96                         try {
  97                                 my $start = time();
  98                                 $resp = $coderef->run( $appreq, @args);
  99                                 my $time = sprintf '%.3f', time() - $start;
 100                                 $log->debug( "Method duration for {$method_name -> ".join(', ', @args)."}:  ". $time, DEBUG );
 101                                 if( ref( $resp ) ) {
 102                                         $log->debug( "Calling respond_complete: ". $resp->toString(), INTERNAL );
 103                                         $appreq->respond_complete( $resp );
 104                                 } else {
 105                                         $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new(
 106                                                                 statusCode => STATUS_COMPLETE(),
 107                                                                 status => 'Request Complete' ) );
 108                                 }
 109                         } catch Error with {
 110                                 my $e = shift;
 111                                 $e = $e->{-text} || $e->message if (ref $e);
 112                                 my $sess_id = $session->session_id;
 113                                 $session->status(
 114                                         OpenSRF::DomainObject::oilsMethodException->new(
 115                                                         statusCode      => STATUS_INTERNALSERVERERROR(),
 116                                                         status          => " *** Call to [$method_name] failed for session ".
 117                                                                            "[$sess_id], thread trace [".$appreq->threadTrace."]:\n".$e
 118                                         )
 119                                 );
 120                         };
 121
 122
 123
 124                         # ----------------------------------------------
 125
 126
 127                         # XXX may need this later
 128                         # $_->[1] = 1 for (@OpenSRF::AppSession::_CLIENT_CACHE);
 129
 130                         $in_request--;
 131
 132                         $log->debug( "Pending Requests: " . scalar(@pending_requests), INTERNAL );
 133
 134                         # cycle through queued requests
 135                         while( my $aref = shift @pending_requests ) {
 136                                 $in_request++;
 137                                 my $resp;
 138                                 try {
 139                                         my $start = time;
 140                                         my $response = $aref->[2]->run( $aref->[0], @{$aref->[1]} );
 141                                         my $time = sprintf '%.3f', time - $start;
 142                                         $log->debug( "Method duration for {[".$aref->[2]->name." -> ".join(', ',@{$aref->[1]}).'}:  '.$time, DEBUG );
 143
 144                                         $appreq = $aref->[0];
 145                                         if( ref( $response ) ) {
 146                                                 $log->debug( "Calling respond_complete: ". $response->toString(), INTERNAL );
 147                                                 $appreq->respond_complete( $response );
 148                                         } else {
 149                                                 $appreq->status( OpenSRF::DomainObject::oilsConnectStatus->new(
 150                                                                         statusCode => STATUS_COMPLETE(),
 151                                                                         status => 'Request Complete' ) );
 152                                         }
 153                                         $log->debug( "Executed: " . $appreq->threadTrace, DEBUG );
 154                                 } catch Error with {
 155                                         my $e = shift;
 156                                         $session->status(
 157                                                 OpenSRF::DomainObject::oilsMethodException->new(
 158                                                                 statusCode => STATUS_INTERNALSERVERERROR(),
 159                                                                 status => "Call to [".$aref->[2]->name."] faild:  ".$e->{-text}
 160                                                 )
 161                                         );
 162                                 };
 163                                 $in_request--;
 164                         }
 165
 166                         return 1;
 167                 }
 168                 my $res = OpenSRF::DomainObject::oilsMethodException->new;
 169                 $session->send('ERROR', $res);
 170                 $session->kill_me;
 171                 return 1;
 172
 173         } else {
 174                 $log->debug( "Pushing ". $app_msg->toString ." onto queue", INTERNAL );
 175                 $session->push_queue([ $app_msg, $session->last_threadTrace ]);
 176         }
 177
 178         $session->last_message_type('');
 179         $session->last_message_protocol('');
 180
 181         return 1;
 182 }
 183
 184 sub register_method {
 185         my $self = shift;
 186         my $app = ref($self) || $self;
 187         my %args = @_;
 188
 189         throw OpenSRF::DomainObject::oilsMethodException unless ($args{method});
 190
 191         $args{protocol} ||= 1;
 192         $args{api_name} ||= $app . '.' . $args{method};
 193         $args{code} ||= \&{$app . '::' . $args{method}};
 194
 195         $_METHODS{$args{api_name}} = bless \%args => $app;
 196 }
 197
 198
 199 sub method_lookup {
 200         my $self = shift;
 201         my $method = shift;
 202         my $proto = shift || 1;
 203
 204         my $class = ref($self) || $self;
 205
 206         $log->debug("Specialized lookup of [$method] in [$class]", DEBUG);
 207         $log->debug("Available methods\n".Dumper(\%_METHODS), INTERNAL);
 208
 209         if (exists $_METHODS{$method}) {
 210                 $log->debug("Looks like we found [$method]", DEBUG);
 211                 my $meth = $_METHODS{$method} if ($_METHODS{$method}{protocol} == $proto);
 212                 $log->debug("Method object is ".Dumper($meth), INTERNAL);
 213                 return $meth;
 214         }
 215
 216         return undef;
 217 }
 218
 219 sub run {
 220         my $self = shift;
 221         my $req = shift;
 222
 223         if ( !ref($req) || !UNIVERSAL::isa($req, 'OpenSRF::AppRequest') ) {
 224                 $log->debug("Creating a SubRequest object", DEBUG);
 225                 unshift @_, $req;
 226                 $req = OpenSRF::AppSubrequest->new;
 227         } else {
 228                 $log->debug("This is a top level request", DEBUG);
 229         }
 230
 231         my $resp = $self->{code}->($self, $req, @_);
 232
 233         if ( ref($req) and UNIVERSAL::isa($req, 'OpenSRF::AppSubrequest') ) {
 234                 $req->respond($resp) if ($resp);
 235                 for my $r ( $req->responses ) {
 236                         $log->debug("A SubRequest object is responding with $r", DEBUG);
 237                 }
 238                 return $req->responses;
 239         } else {
 240                 $log->debug("A top level Request object is responding $resp", DEBUG);
 241         }
 242
 243         return $resp;
 244 }
 245
 246 1;