1 package OpenILS::WWW::XMLRPCGateway;
2 use strict; use warnings;
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;
12 use UNIVERSAL::require;
15 use OpenSRF::EX qw(:try);
17 use OpenSRF::Utils::Cache;
18 use OpenSRF::Utils::Logger qw/$logger/;
19 use OpenSRF::Utils::SettingsClient;
21 use RPC::XML qw/smart_encode/;
24 use RPC::XML::Procedure;
26 $RPC::XML::ENCODING = 'utf-8';
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?
35 # set the bootstrap config when this module is loaded
36 sub import { $bs_config = $_[1]; }
39 # Bootstrap and load config settings
42 OpenSRF::AppSession->ingress('xmlrpc');
43 OpenSRF::System->bootstrap_client( config_file => $bs_config );
44 my $sclient = OpenSRF::Utils::SettingsClient->new();
45 my $idl = $sclient->config_value("IDL");
46 $services = $sclient->config_value("xml-rpc", "allowed_services", "service");
47 $services = ref $services ? $services : [ $services ];
48 $logger->debug("XML-RPC: allowed services @$services");
49 OpenILS::Utils::Fieldmapper->require;
50 Fieldmapper->import(IDL => $idl);
51 OpenSRF::AppSession->ingress('apache');
52 return Apache2::Const::OK;
60 my $service = $r->path_info;
63 child_init() unless $__inited; # ?
65 return Apache2::Const::NOT_FOUND unless grep { $_ eq $service } @$services;
67 my $request = RPC::XML::Parser->new->parse($cgi->param('POSTDATA'));
70 push( @args, unwrap_perl($_->value) ) for @{$request->args};
71 my $method = $request->name;
73 warn "XML-RPC: service=$service, method=$method, args=@args\n";
74 $logger->debug("XML-RPC: service=$service, method=$method, args=@args");
76 my $perl = run_request( $service, $method, @args );
77 my $resp = RPC::XML::response->new(smart_encode($perl));
79 print "Content-type: application/xml; charset=utf-8\n\n";
80 print $resp->as_string;
81 return Apache2::Const::OK;
86 my( $service, $method, @args ) = @_;
88 $method =~ s/__/-/g; # Our methods have dashes in them, but that's not
89 # actually a valid character in XML-RPC method
90 # names, and some clients enforce that restriction
93 # since multiple Perl clients run within mod_perl,
94 # we must set our ingress before each request.
95 OpenSRF::AppSession->ingress('xmlrpc');
97 my $ses = OpenSRF::AppSession->create( $service );
100 my $req = $ses->request($method, @args);
101 while( my $resp = $req->recv( timeout => 600 ) ) {
103 push( @$data, $req->failed );
106 push( @$data, $resp->content );
109 # recover the default Apache/http ingress to avoid
110 # polluting other mod_perl clients w/ our ingress value.
111 OpenSRF::AppSession->ingress('apache');
113 return [] if scalar(@$data) == 0;
114 return wrap_perl($$data[0])
115 if scalar(@$data) == 1 and $method !~ /.atomic$/og;
116 return wrap_perl($data);
119 # These should probably be moved out to a library somewhere
125 if ($ref =~ /^Fieldmapper/o) {
126 $ref = $obj->json_hint;
127 $obj = $obj->to_bare_hash;
130 if( $ref eq 'HASH' ) {
131 $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
132 } elsif( $ref eq 'ARRAY' ) {
133 $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1 );
135 if(UNIVERSAL::isa($obj, 'HASH')) {
136 $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
137 bless($obj, 'HASH'); # so our parser won't add the hints
138 } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
139 $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1);
140 bless($obj, 'ARRAY'); # so our parser won't add the hints
142 $obj = { $CLASS_KEY => $ref, $PAYLOAD_KEY => $obj };
152 if( $ref eq 'HASH' ) {
153 if( defined($obj->{$CLASS_KEY})) {
154 my $class = $obj->{$CLASS_KEY};
155 if( $obj = unwrap_perl($obj->{$PAYLOAD_KEY}) ) {
156 return bless(\$obj, $class) unless ref($obj);
157 return bless( $obj, $class );
161 $obj->{$_} = unwrap_perl( $obj->{$_} ) for (keys %$obj);
162 } elsif( $ref eq 'ARRAY' ) {
163 $obj->[$_] = unwrap_perl($obj->[$_]) for(0..scalar(@$obj) - 1);