Open-ILS/src/perlmods/lib/OpenILS/WWW/XMLRPCGateway.pm

   1 package OpenILS::WWW::XMLRPCGateway;
   2 use strict; use warnings;
   3
   4 use CGI;
   5 use Apache2::Log;
   6 use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
   7 use APR::Const    -compile => qw(:error SUCCESS);
   8 use Apache2::RequestRec ();
   9 use Apache2::RequestIO ();
  10 use Apache2::RequestUtil;
  11 use Data::Dumper;
  12 use UNIVERSAL::require;
  13
  14 use XML::LibXML;
  15 use OpenSRF::EX qw(:try);
  16 use OpenSRF::System;
  17 use OpenSRF::Utils::Cache;
  18 use OpenSRF::Utils::Logger qw/$logger/;
  19 use OpenSRF::Utils::SettingsClient;
  20
  21 use RPC::XML qw/smart_encode/;
  22 use RPC::XML::Parser;
  23 use RPC::XML::Procedure;
  24
  25 $RPC::XML::ENCODING = 'utf-8';
  26
  27 my $services;                                           # allowed services
  28 my $CLASS_KEY = '__class__';    # object wrapper class key
  29 my $PAYLOAD_KEY = '__data__';   # object wrapper payload key
  30 my $bs_config;                                  # bootstrap config
  31 my $__inited = 0;                               # has child_init run?
  32
  33
  34 # set the bootstrap config when this module is loaded
  35 sub import { $bs_config = $_[1]; }
  36
  37
  38 # Bootstrap and load config settings
  39 sub child_init {
  40         $__inited = 1;
  41         OpenSRF::AppSession->ingress('xmlrpc');
  42         OpenSRF::System->bootstrap_client( config_file => $bs_config );
  43         my $sclient     = OpenSRF::Utils::SettingsClient->new();
  44         my $idl = $sclient->config_value("IDL");
  45         $services = $sclient->config_value("xml-rpc", "allowed_services", "service");
  46         $services = ref $services ? $services : [ $services ];
  47         $logger->debug("XML-RPC: allowed services @$services");
  48         OpenILS::Utils::Fieldmapper->require;
  49         Fieldmapper->import(IDL => $idl);
  50         OpenSRF::AppSession->ingress('apache');
  51         return Apache2::Const::OK;
  52 }
  53
  54
  55 sub handler {
  56
  57         my $r           = shift;
  58         my $cgi = CGI->new;
  59         my $service = $r->path_info;
  60         $service =~ s#^/##;
  61
  62         child_init() unless $__inited; # ?
  63
  64         return Apache2::Const::NOT_FOUND unless grep { $_ eq $service } @$services;
  65
  66         my $request = RPC::XML::Parser->new->parse($cgi->param('POSTDATA'));
  67
  68         my @args;
  69         push( @args, unwrap_perl($_->value) ) for @{$request->args};
  70         my $method = $request->name;
  71
  72         warn "XML-RPC: service=$service, method=$method, args=@args\n";
  73         $logger->debug("XML-RPC: service=$service, method=$method, args=@args");
  74
  75         my $perl = run_request( $service, $method, @args );
  76         my $resp = RPC::XML::response->new(smart_encode($perl));
  77
  78         print "Content-type: application/xml; charset=utf-8\n\n";
  79         print $resp->as_string;
  80         return Apache2::Const::OK;
  81 }
  82
  83
  84 sub run_request {
  85     my( $service, $method, @args ) = @_;
  86
  87     $method =~ s/__/-/g;    # Our methods have dashes in them, but that's not
  88                             # actually a valid character in XML-RPC method
  89                             # names, and some clients enforce that restriction
  90                             # on their users.
  91
  92     # since multiple Perl clients run within mod_perl,
  93     # we must set our ingress before each request.
  94     OpenSRF::AppSession->ingress('xmlrpc');
  95
  96     my $ses = OpenSRF::AppSession->create( $service );
  97
  98     my $data = [];
  99     my $req = $ses->request($method, @args);
 100     while( my $resp = $req->recv( timeout => 600 ) ) {
 101         if( $req->failed ) {
 102             push( @$data, $req->failed );
 103             last;
 104         }
 105         push( @$data, $resp->content );
 106     }
 107
 108     # recover the default Apache/http ingress to avoid
 109     # polluting other mod_perl clients w/ our ingress value.
 110     OpenSRF::AppSession->ingress('apache');
 111
 112     return [] if scalar(@$data) == 0;
 113     return wrap_perl($$data[0])
 114         if scalar(@$data) == 1 and $method !~ /.atomic$/og;
 115     return wrap_perl($data);
 116 }
 117
 118 # These should probably be moved out to a library somewhere
 119
 120 sub wrap_perl {
 121    my $obj = shift;
 122    my $ref = ref($obj);
 123
 124    if ($ref =~ /^Fieldmapper/o) {
 125       $ref = $obj->json_hint;
 126       $obj = $obj->to_bare_hash;
 127    }
 128
 129    if( $ref eq 'HASH' ) {
 130       $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
 131    } elsif( $ref eq 'ARRAY' ) {
 132       $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1 );
 133    } elsif( $ref ) {
 134       if(UNIVERSAL::isa($obj, 'HASH')) {
 135          $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
 136          bless($obj, 'HASH'); # so our parser won't add the hints
 137       } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 138          $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1);
 139          bless($obj, 'ARRAY'); # so our parser won't add the hints
 140       }
 141       $obj = { $CLASS_KEY => $ref, $PAYLOAD_KEY => $obj };
 142    }
 143    return $obj;
 144 }
 145
 146
 147
 148 sub unwrap_perl {
 149    my $obj = shift;
 150    my $ref = ref($obj);
 151    if( $ref eq 'HASH' ) {
 152       if( defined($obj->{$CLASS_KEY})) {
 153          my $class = $obj->{$CLASS_KEY};
 154          if( $obj = unwrap_perl($obj->{$PAYLOAD_KEY}) ) {
 155             return bless(\$obj, $class) unless ref($obj);
 156             return bless( $obj, $class );
 157          }
 158          return undef;
 159       }
 160       $obj->{$_} = unwrap_perl( $obj->{$_} ) for (keys %$obj);
 161    } elsif( $ref eq 'ARRAY' ) {
 162       $obj->[$_] = unwrap_perl($obj->[$_]) for(0..scalar(@$obj) - 1);
 163    }
 164    return $obj;
 165 }
 166
 167
 168
 169
 170 1;