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

   1 package OpenILS::WWW::XMLRPCGateway;
   2 use strict; use warnings;
   3
   4 use CGI;
   5 use Apache2 ();
   6 use Apache2::Log;
   7 use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
   8 use APR::Const    -compile => qw(:error SUCCESS);
   9 use Apache2::RequestRec ();
  10 use Apache2::RequestIO ();
  11 use Apache2::RequestUtil;
  12 use Data::Dumper;
  13 use UNIVERSAL::require;
  14
  15 use XML::LibXML;
  16 use OpenSRF::EX qw(:try);
  17 use OpenSRF::System;
  18 use OpenSRF::Utils::Cache;
  19 use OpenSRF::Utils::Logger qw/$logger/;
  20 use OpenSRF::Utils::SettingsClient;
  21
  22 use RPC::XML qw/smart_encode/;
  23 use RPC::XML::Parser;
  24 use RPC::XML::Function;
  25 use RPC::XML::Method;
  26 use RPC::XML::Procedure;
  27
  28 my $services;                                           # allowed services
  29 my $CLASS_KEY = '__class__';    # object wrapper class key
  30 my $PAYLOAD_KEY = '__data__';   # object wrapper payload key
  31 my $bs_config;                                  # bootstrap config
  32 my $__inited = 0;                               # has child_init run?
  33
  34
  35 # set the bootstrap config when this module is loaded
  36 sub import { $bs_config = $_[1]; }
  37
  38
  39 # Bootstrap and load config settings
  40 sub child_init {
  41         $__inited = 1;
  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 }
  51
  52
  53 sub handler {
  54
  55         my $r           = shift;
  56         my $cgi = CGI->new;
  57         my $service = $r->path_info;
  58         $service =~ s#^/##;
  59
  60         child_init() unless $__inited; # ?
  61
  62         return Apache2::Const::NOT_FOUND unless grep { $_ eq $service } @$services;
  63
  64         my $request = RPC::XML::Parser->new->parse($cgi->param('POSTDATA'));
  65
  66         my @args;
  67         push( @args, unwrap_perl($_->value) ) for @{$request->args};
  68         my $method = $request->name;
  69
  70         warn "XML-RPC: service=$service, method=$method, args=@args\n";
  71         $logger->debug("XML-RPC: service=$service, method=$method, args=@args");
  72
  73         my $perl = run_request( $service, $method, @args );
  74         my $resp = RPC::XML::response->new(smart_encode($perl));
  75
  76         print "Content-type: application/xml; charset=utf-8\n\n";
  77         print $resp->as_string;
  78         return Apache2::Const::OK;
  79 }
  80
  81
  82 sub run_request {
  83         my( $service, $method, @args ) = @_;
  84         my $ses = OpenSRF::AppSession->create( $service );
  85         my $data = $ses->request($method, @args)->gather(1);
  86         return wrap_perl($data);
  87 }
  88
  89 # These should probably be moved out to a library somewhere
  90
  91 sub wrap_perl {
  92    my $obj = shift;
  93    my $ref = ref($obj);
  94
  95    if ($ref =~ /^Fieldmapper/o) {
  96       $ref = $obj->json_hint;
  97       $obj = $obj->to_bare_hash;
  98    }
  99
 100    if( $ref eq 'HASH' ) {
 101       $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
 102    } elsif( $ref eq 'ARRAY' ) {
 103       $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1 );
 104    } elsif( $ref ) {
 105       if(UNIVERSAL::isa($obj, 'HASH')) {
 106          $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
 107          bless($obj, 'HASH'); # so our parser won't add the hints
 108       } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 109          $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1);
 110          bless($obj, 'ARRAY'); # so our parser won't add the hints
 111       }
 112       $obj = { $CLASS_KEY => $ref, $PAYLOAD_KEY => $obj };
 113    }
 114    return $obj;
 115 }
 116
 117
 118
 119 sub unwrap_perl {
 120    my $obj = shift;
 121    my $ref = ref($obj);
 122    if( $ref eq 'HASH' ) {
 123       if( defined($obj->{$CLASS_KEY})) {
 124          my $class = $obj->{$CLASS_KEY};
 125          if( $obj = unwrap_perl($obj->{$PAYLOAD_KEY}) ) {
 126             return bless(\$obj, $class) unless ref($obj);
 127             return bless( $obj, $class );
 128          }
 129          return undef;
 130       }
 131       $obj->{$_} = unwrap_perl( $obj->{$_} ) for (keys %$obj);
 132    } elsif( $ref eq 'ARRAY' ) {
 133       $obj->[$_] = unwrap_perl($obj->[$_]) for(0..scalar(@$obj) - 1);
 134    }
 135    return $obj;
 136 }
 137
 138
 139
 140
 141 1;