no need to commit on read, rollback instead
[Evergreen.git] / Open-ILS / src / perlmods / OpenILS / Application / PermaCrud.pm
1 # vim:et:ts=4:sw=4:
2
3 package OpenILS::Application::PermaCrud;
4 use OpenILS::Application;
5 use base qw/OpenILS::Application/;
6
7 use Unicode::Normalize;
8 use OpenSRF::EX qw/:try/;
9
10 use OpenSRF::AppSession;
11 use OpenSRF::Utils::SettingsClient;
12 use OpenSRF::Utils::Logger qw/:level/;
13
14 use OpenILS::Utils::Fieldmapper;
15 use OpenSRF::Utils::JSON;
16
17 use OpenILS::Utils::CStoreEditor qw/:funcs/;
18
19 use XML::LibXML;
20 use XML::LibXML::XPathContext;
21 use XML::LibXSLT;
22 use OpenILS::Event;
23
24 our %namespace_map = (
25     oils_persist=> {ns => 'http://open-ils.org/spec/opensrf/IDL/persistence/v1'},
26     oils_obj    => {ns => 'http://open-ils.org/spec/opensrf/IDL/objects/v1'},
27     idl         => {ns => 'http://opensrf.org/spec/IDL/base/v1'},
28     reporter    => {ns => 'http://open-ils.org/spec/opensrf/IDL/reporter/v1'},
29     perm        => {ns => 'http://open-ils.org/spec/opensrf/IDL/permacrud/v1'},
30 );
31
32
33 my $log = 'OpenSRF::Utils::Logger';
34
35 my $parser = XML::LibXML->new();
36 my $xslt = XML::LibXSLT->new();
37
38 my $xpc = XML::LibXML::XPathContext->new();
39 $xpc->registerNs($_, $namespace_map{$_}{ns}) for ( keys %namespace_map );
40
41 my $idl;
42
43 sub initialize {
44
45     my $conf = OpenSRF::Utils::SettingsClient->new;
46     my $idl_file = $conf->config_value( 'IDL' );
47
48     $idl = $parser->parse_file( $idl_file );
49
50     $log->debug( 'IDL XML file loaded' );
51
52     generate_methods();
53
54 }
55 sub child_init {}
56
57 sub CRUD_action_object_permcheck {
58     my $self = shift;
59     my $client = shift;
60     my $auth = shift;
61     my $obj = shift;
62
63     my $e = shift || new_editor(authtoken => $auth, xact => 1);
64     return $e->event unless $e->checkauth;
65
66     if (ref($obj) && $obj->json_hint ne $self->{class_hint}) {
67         throw OpenSRF::DomainObject::oilsException->new(
68             statusCode => 500,
69             status => "Class missmatch: $self->{class_hint} method called with " . $obj->json_hint,
70         );
71     }
72
73     my $class_node;
74     try {
75         ($class_node) = $xpc->findnodes( "//idl:class[\@id='$self->{class_hint}']", $idl->documentElement );
76     } catch Error with {
77         my $error = shift;
78         $log->error("Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]");
79         throw OpenSRF::DomainObject::oilsException->new(
80             statusCode => 500,
81             status => "Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]"
82         );
83     };
84
85     if (!$class_node) {
86         $log->error("Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]");
87         throw OpenSRF::DomainObject::oilsException->new(
88             statusCode => 500,
89             status => "Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]"
90         );
91     }
92
93     my $action_node;
94     try {
95         ($action_node) = $xpc->findnodes( "perm:permacrud/perm:actions/perm:$self->{action}", $class_node );
96     } catch Error with {
97         my $error = shift;
98         $log->error("Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]");
99         throw OpenSRF::DomainObject::oilsException->new(
100             statusCode => 500,
101             status => "Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]"
102         );
103     };
104
105     if (!$action_node) {
106         $log->error("Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]");
107         throw OpenSRF::DomainObject::oilsException->new(
108             statusCode => 500,
109             status => "Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]"
110         );
111     }
112
113     my $all_perms = $action_node->getAttribute( 'all_perms' );
114
115     my $fm_class = $xpc->findvalue( '@oils_obj:fieldmapper', $class_node );
116     if (!ref($obj)) {
117         my $retrieve_method = 'retrieve_' . $fm_class;
118         $retrieve_method =~ s/::/_/go;
119         $obj = $e->$retrieve_method( $obj );
120     }
121
122     (my $o_type = $fm_class) =~ s/::/./go;
123
124     my $perm_field_value = $action_node->getAttribute('permission');
125
126     if ($perm_field_value) {
127         my @perms = split '\|', $perm_field_value;
128
129         my @context_ous;
130         if ($action_node->getAttribute('global_required')) {
131             push @context_ous, $e->search_actor_org_unit( { parent_ou => undef } )->[0]->id;
132
133         } else {
134             my $context_field_value = $action_node->getAttribute('context_field');
135
136             if ($context_field_value) {
137                 push @context_ous, $obj->$_ for ( split '\|', $context_field_value );
138             } else {  
139                 for my $context_node ( $xpc->findnodes( "perm:context", $action_node ) ) {
140                     my $context_field = $context_node->getAttribute('field');
141                     my $link_field = $context_node->getAttribute('link');
142
143                     if ($link_field) {
144
145                         my ($link_node) = $xpc->findnodes( "idl:links/idl:link[\@field='$link_field']", $class_node );
146                         my $link_class_hint = $link_node->getAttribute('class');
147                         my $remote_field = $link_node->getAttribute('key');
148
149                         my ($remote_class_node) = $xpc->findnodes( "//idl:class[\@id='$link_class_hint']", $idl->documentElement );
150                         my $search_method = 'search_' . $xpc->findvalue( '@oils_obj:fieldmapper', $remote_class_node );
151                         $search_method =~ s/::/_/go;
152
153                         for my $remote_object ( @{$e->$search_method( { $remote_field => $obj->$link_field } )} ) {
154                             push @context_ous, $remote_object->$context_field;
155                         }
156                     } else {
157                         push @context_ous, $obj->$_ for ( split '\|', $context_field );
158                     }
159                 }
160             }
161         }
162
163         my $pok = 0;
164         for my $perm (@perms) {
165             if (@context_ous) {
166                 for my $c_ou (@context_ous) {
167                     if ($e->allowed($perm => $c_ou => $obj)) {
168                         $pok++;
169                         last;
170                     }
171                 }
172             } else {
173                 $pok++ if ($e->allowed($perm => undef => $obj));
174             }
175         }
176
177         if ((lc($all_perms) eq 'true' && @perms != $pok) or !$pok) {
178                 return OpenILS::Event->new('PERM_FAILURE', 
179                 ilsperm => "", # XXX add logic to report which perm failed
180                 ilspermloc => "",
181                 payload => "Perm failure -- action: $self->{action}, object type: $self->{json_hint}",
182             );
183         }
184     }
185
186     if ($self->{action} eq 'retrieve') {
187         $e->rollback;
188         return $obj;
189     }
190
191     my $val = $e->session->request("open-ils.cstore.direct.$o_type.$self->{action}" => $obj )->gather(1);
192     $e->commit;
193
194     return $val;
195 }
196
197 sub search_permacrud {
198     my $self = shift;
199     my $client = shift;
200     my $auth = shift;
201     my @args = @_;
202
203     if (@args > 1) {
204         delete $args[1]{flesh};
205         delete $args[1]{flesh_fields};
206     }
207
208     my $e = new_editor(authtoken => $auth, xact => 1);
209     return $e->event unless $e->checkauth;
210  
211     my $class_node;
212     try {
213         ($class_node) = $xpc->findnodes( "//idl:class[\@id='$self->{class_hint}']", $idl->documentElement );
214     } catch Error with {
215         my $error = shift;
216         $log->error("Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]");
217         throw OpenSRF::DomainObject::oilsException->new(
218             statusCode => 500,
219             status => "Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]"
220         );
221     };
222
223     my $search_method = 'search_' . $xpc->findvalue( '@oils_obj:fieldmapper', $class_node );
224     $search_method =~ s/::/_/go;
225
226     $log->debug("Calling CStoreEditor search method: $search_method");
227
228     my $obj_list = $e->$search_method( \@args );
229
230     my $retriever = $self->method_lookup( $self->{retriever} );
231     for my $o ( @$obj_list ) {
232         try {
233             ($o) = $retriever->run( $auth, $o, $e );
234             $client->respond( $o ) if ($o);
235         };
236     }
237
238     return undef;
239 }
240
241 sub generate_methods {
242     try {
243         for my $class_node ( $xpc->findnodes( '//idl:class[perm:permacrud]', $idl->documentElement ) ) {
244             my $hint = $class_node->getAttribute('id');
245             $log->debug("permacrud class_node $hint");
246         
247             for my $action_node ( $xpc->findnodes( "perm:permacrud/perm:actions/perm:*", $class_node ) ) {
248                 (my $method = $action_node->localname) =~ s/^.+:(.+)$/$1/o;
249                 $log->internal("permacrud method = $method");
250         
251                 __PACKAGE__->register_method(
252                     method          => 'CRUD_action_object_permcheck',
253                     api_name        => 'open-ils.permacrud.' . $method . '.' . $hint,
254                     class_hint      => $hint,
255                     action          => $method,
256                 );
257         
258                 if ($method eq 'retrieve') {
259                     __PACKAGE__->register_method(
260                         method          => 'search_permacrud',
261                         api_name        => 'open-ils.permacrud.search.' . $hint,
262                         class_hint      => $hint,
263                         retriever       => 'open-ils.permacrud.retrieve.' . $hint,
264                         stream          => 1
265                     );
266                 }
267             }
268         }
269     } catch Error with {
270         my $e = shift;
271         $log->error("error generating permacrud methods: $e");
272     };
273 }
274
275
276 1;
277