initial permacrud application
[Evergreen.git] / Open-ILS / src / perlmods / OpenILS / Application / PermaCrud.pm
1 package OpenILS::Application::PermaCrud;
2 use OpenILS::Application;
3 use base qw/OpenILS::Application/;
4
5 use Unicode::Normalize;
6 use OpenSRF::EX qw/:try/;
7
8 use OpenSRF::AppSession;
9 use OpenSRF::Utils::SettingsClient;
10 use OpenSRF::Utils::Logger qw/:level/;
11
12 use OpenILS::Utils::Fieldmapper;
13 use OpenSRF::Utils::JSON;
14
15 use OpenILS::Utils::CStoreEditor qw/:funcs/;
16
17 use XML::LibXML;
18 use XML::LibXML::XPathContext;
19 use XML::LibXSLT;
20
21 our %namespace_map = (
22     oils_persist=> {ns => 'http://open-ils.org/spec/opensrf/IDL/persistence/v1'},
23     oils_obj    => {ns => 'http://open-ils.org/spec/opensrf/IDL/objects/v1'},
24     idl         => {ns => 'http://opensrf.org/spec/IDL/base/v1'},
25     reporter    => {ns => 'http://open-ils.org/spec/opensrf/IDL/reporter/v1'},
26 );
27
28
29 my $log = 'OpenSRF::Utils::Logger';
30
31 my $parser = XML::LibXML->new();
32 my $xslt = XML::LibXSLT->new();
33
34 my $xpc = XML::LibXML::XPathContext->new();
35 $xpc->registerNs($_, $namespace_map{$_}{ns}) for ( keys %namespace_map );
36
37 my $idl;
38
39 sub initialize {
40
41     my $conf = OpenSRF::Utils::SettingsClient->new;
42     my $idl_file = $conf->config_value( 'IDL' );
43
44     $idl = $parser->parse_file( $idl_file );
45
46     $log->debug( 'IDL XML file loaded' );
47 }
48 sub child_init {}
49
50 sub CRUD_action_object_permcheck {
51     my $self = shift;
52     my $client = shift;
53     my $auth = shift;
54     my $obj = shift;
55
56     my $e = new_editor(authtoken => $auth, xact => 1);
57     return $e->event unless $e->checkauth;
58
59     unless ($obj->json_hint eq $self->{class_hint}) {
60         throw OpenSRF::DomainObject::oilsException->new(
61             statusCode => 500,
62             status => "Class missmatch: $self->{class_hint} method called with " . $obj->json_hint,
63         );
64     }
65
66     my $action = $self->api_name =~ s/^open-ils\.admin\.([^\.])\..+$/$1/o;
67     my $o_type = $obj->cdbi =~ s/::/./go;
68
69     my ($class_node) = $xpc->findnodes( "//idl:class[\@id='$self->{class_hint}']", $idl->documentElement );
70     my ($action_node) = $xpc->findnodes( "perm:permacrud/perm:actions/perm:$action", $class_node );
71
72     my $perm_field_value = $aciton_node->getAttribute('permission');
73
74     if (defined($perm_field_value)) 
75         my @perms = split '|', $aciton_node->getAttribute('permission');
76
77         my @context_ous;
78         if ($aciton_node->getAttribute('global_required')) {
79             push @context_ous, $e->search_actor_org_unit( { parent_ou => undef } )->[0]->id;
80
81         } else {
82             my $context_field_value = $aciton_node->getAttribute('context_field');
83
84             if (defined($context_field_value)) {
85                 push @context_ous, $obj->$_ for ( split '|', $context_field_value );
86             } else {  
87                 for my $context_node ( $xpc->findnodes( "perm:context", $action_node ) ) {
88                     my $context_field = $context_node->getAttribute('field');
89                     my $link_field = $context_node->getAttribute('link');
90
91                     my ($link_node) = $xpc->findnodes( "idl:links/idl:link[\@field='$link_field']", $class_node );
92                     my $link_class_hint = $link_node->getAttribute('class');
93                     my $remote_field = $link_node->getAttribute('key');
94
95                     my ($remote_class_node) = $xpc->findnodes( "//idl:class[\@id='$self->{class_hint}']", $idl->documentElement );
96                     my $search_method = 'search_' . $xpc->findvalue( '@oils_obj:fieldmapper', $remote_class_node );
97                     $search_method =~ s/::/_/go;
98
99                     for my $remote_object ( @{$e->$search_method( { $key => $obj->$link_field } )} ) {
100                         push @context_ous, $remote_object->$context_field;
101                     }
102                 }
103             }
104         }
105
106         my ($pok, $cok) = (0, 0);
107         for my $perm (@perms) {
108             for my $c_ou (@context_ous) {
109                 if ($e->allowed($perm => $c_ou => $obj)) {
110                     $cok++;
111                     last;
112                 }
113             }
114             $pok++ if ($cok);
115             $cok = 0;
116         }
117
118         unless (@perms == $pok) {
119             throw OpenSRF::DomainObject::oilsException->new(
120                 statusCode => 500,
121                 status => "Perm failure -- action: $action, object type: $self->{json_hint}",
122             );
123         }
124     }
125 }
126
127 for my $class_node ( $xpc->findnodes( "perm:permacrud/perm:actions/perm:$action", $class_node ) ) {
128     my $hint = $class_node->getAttribute('id');
129
130     for my $action_node ( $xpc->findnodes( "perm:permacrud/perm:actions/perm:*", $class_node ) ) {
131         my $method = $action_node->localname =~ s/^.+:(.+)$/$1/o;
132
133         __PACKAGE__->register_method(
134             method      => 'CRUD_action_object_permcheck',
135             api_name    => 'open-ils.permacrud.' . $method . '.' . $hint,
136             class_hint  => $hint,
137         );
138
139     }
140 }
141     
142
143
144 1;
145