9e4a4c1875747d22862482d91bfd959dcaf0ae78
[working/Evergreen.git] / 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::Method;
24 use RPC::XML::Procedure;
25
26 $RPC::XML::ENCODING = 'utf-8';
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::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;
53 }
54
55
56 sub handler {
57
58         my $r           = shift;
59         my $cgi = CGI->new;
60         my $service = $r->path_info;
61         $service =~ s#^/##;
62
63         child_init() unless $__inited; # ?
64
65         return Apache2::Const::NOT_FOUND unless grep { $_ eq $service } @$services;
66
67         my $request = RPC::XML::Parser->new->parse($cgi->param('POSTDATA'));
68
69         my @args;
70         push( @args, unwrap_perl($_->value) ) for @{$request->args};
71         my $method = $request->name;
72
73         warn "XML-RPC: service=$service, method=$method, args=@args\n";
74         $logger->debug("XML-RPC: service=$service, method=$method, args=@args");
75
76         my $perl = run_request( $service, $method, @args );
77         my $resp = RPC::XML::response->new(smart_encode($perl));
78
79         print "Content-type: application/xml; charset=utf-8\n\n";
80         print $resp->as_string;
81         return Apache2::Const::OK;
82 }
83
84
85 sub run_request {
86     my( $service, $method, @args ) = @_;
87
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
91                             # on their users.
92
93     # since multiple Perl clients run within mod_perl, 
94     # we must set our ingress before each request.
95     OpenSRF::AppSession->ingress('xmlrpc');
96
97     my $ses = OpenSRF::AppSession->create( $service );
98
99     my $data = [];
100     my $req = $ses->request($method, @args);
101     while( my $resp = $req->recv( timeout => 600 ) ) {
102         if( $req->failed ) {
103             push( @$data, $req->failed );
104             last;
105         }
106         push( @$data, $resp->content );
107     }
108
109     # recover the default Apache/http ingress to avoid 
110     # polluting other mod_perl clients w/ our ingress value.
111     OpenSRF::AppSession->ingress('apache');
112
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);
117 }
118
119 # These should probably be moved out to a library somewhere
120
121 sub wrap_perl {
122    my $obj = shift;
123    my $ref = ref($obj);
124
125    if ($ref =~ /^Fieldmapper/o) {
126       $ref = $obj->json_hint;
127       $obj = $obj->to_bare_hash;
128    }
129
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 );
134    } elsif( $ref ) {
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
141       }
142       $obj = { $CLASS_KEY => $ref, $PAYLOAD_KEY => $obj };
143    }
144    return $obj;
145 }
146
147
148
149 sub unwrap_perl {
150    my $obj = shift;
151    my $ref = ref($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 );
158          }
159          return undef;
160       }
161       $obj->{$_} = unwrap_perl( $obj->{$_} ) for (keys %$obj);
162    } elsif( $ref eq 'ARRAY' ) {
163       $obj->[$_] = unwrap_perl($obj->[$_]) for(0..scalar(@$obj) - 1);
164    }
165    return $obj;
166 }
167
168
169
170
171 1;