Make Evergreen Perl modules installable via Module::Build to match OpenSRF
[working/Evergreen.git] / Open-ILS / src / perlmods / lib / OpenILS / Application / Actor / Friends.pm
1 package OpenILS::Application::Actor::Friends;
2 use strict; use warnings;
3 use OpenILS::Application::AppUtils;
4 use OpenILS::Utils::CStoreEditor q/:funcs/;
5 use OpenSRF::Utils::Logger q/$logger/;
6 use OpenILS::Utils::Fieldmapper;
7 my $U = "OpenILS::Application::AppUtils";
8
9 # ----------------------------------------------------------------
10 # Shared Friend utilities.  Thar be no methods published here...
11 # ----------------------------------------------------------------
12
13 # export these fields for friend display
14 my @expose_user_fields = qw/id usrname first_given_name second_given_name family_name alias/;
15
16 my $out_links_query = {
17     select => {cubi => ['target_user']}, 
18     from => {
19         cub => {
20             cubi => {field => 'bucket', fkey => 'id'}
21         }
22     }, 
23     where => {
24         '+cub' => {btype => 'folks', owner => undef}
25     }
26 };
27
28 my $in_links_query = { 
29     select => {cub =>  ['owner'] }, 
30     from => {
31         cub => {
32             cubi => {field => 'bucket', fkey => 'id'}
33         }
34     }, 
35     where => {
36         '+cubi' => {target_user => undef}, 
37         '+cub' => {btype => 'folks'}
38     }
39 };
40
41 my $perm_check_query = { 
42     select => {cub =>  ['btype'] }, 
43     from => {
44         cub => {
45             cubi => {field => 'bucket', fkey => 'id'}
46         }
47     }, 
48 };
49
50 sub retrieve_friends {
51     my($self, $e, $user_id, $options) = @_;
52     $options ||= {};
53
54     # users I have links to
55     $out_links_query->{where}->{'+cub'}->{owner} = $user_id;
56     my @out_linked = map {$_->{target_user}} @{$e->json_query($out_links_query)};
57
58     # users who link to me
59     $in_links_query->{where}->{'+cubi'}->{target_user} = $user_id;
60     my @in_linked = map {$_->{owner}} @{$e->json_query($in_links_query)};
61
62     # determine which users are confirmed, pending outbound 
63     # requests, and pending inbound requests
64     my @confirmed;
65     my @pending_out;
66     my @pending_in;
67
68     for my $out_link (@out_linked) {
69         if(grep {$_ == $out_link} @in_linked) {
70             push(@confirmed, $out_link);
71         } else {
72             push(@pending_out, $out_link);
73         }
74     }
75
76     for my $in_link (@in_linked) {
77         push(@pending_in, $in_link)
78             unless grep {$_ == $in_link} @confirmed;
79     }
80
81     if($$options{confirmed_only}) {
82         return {
83             confirmed => $self->load_linked_user_perms($e, $user_id, @confirmed),
84         };
85     } else {
86         return {
87             confirmed => $self->load_linked_user_perms($e, $user_id, @confirmed),
88             pending_out => $self->load_linked_user_perms($e, $user_id, @pending_out),
89             pending_in => $self->load_linked_user_perms($e, $user_id, @pending_in)
90         };
91     }
92 }
93
94 # given a base user and set of linked users, returns the trimmed linked user
95 # records, plus the perms (by name) each user has been granted
96 sub load_linked_user_perms {
97     my($self, $e, $user_id, @users) = @_;
98     my $items = [];
99
100     # use this query to retrieve trimmed linked user objects
101     my $user_select = 
102         {select => {au => \@expose_user_fields}, from => 'au', where => undef};
103
104     for my $d_user (@users) {
105
106         # fetch all of the bucket items linked from base user to 
107         # delegate user with the folks: prefix on the bucket type
108         $perm_check_query->{where} = {
109             '+cubi' => {target_user => $d_user},
110             '+cub' => {btype => {like => 'folks:%'}, owner => $user_id}
111         };
112
113         my $perms_granted = [ 
114             map {substr($_->{btype}, 6)} @{$e->json_query($perm_check_query)}];
115
116         # fetch all of the bucket items linked from the delegate user 
117         # to the base user with the folks: prefix on the bucket type
118         $perm_check_query->{where} = {
119             '+cubi' => {target_user => $user_id},
120             '+cub' => {btype => {like => 'folks:%'}, owner => $d_user}
121         };
122
123         my $perms_received = [ 
124             map {substr($_->{btype}, 6)} @{$e->json_query($perm_check_query)}];
125
126         $user_select->{where} = {id => $d_user};
127         push(@$items, {
128                 user => $e->json_query($user_select)->[0],
129                 perms_granted => $perms_granted,
130                 perms_received => $perms_received
131             }
132         );
133     }
134     return $items;
135 }
136
137
138 my $direct_links_query = { 
139     select => {cub =>  ['id'] }, 
140     from => {
141         cub => {
142             cubi => {field => 'bucket', fkey => 'id'}
143         }
144     }, 
145     where => {
146         '+cubi' => {target_user => undef}, 
147         '+cub' => {btype => 'folks', owner => undef}
148     },
149     limit => 1
150 };
151
152 sub confirmed_friends {
153     my($self, $e, $user1_id, $user2_id) = @_;
154
155     $direct_links_query->{where}->{'+cub'}->{owner} = $user1_id;
156     $direct_links_query->{where}->{'+cubi'}->{target_user} = $user2_id;
157
158     if($e->json_query($direct_links_query)->[0]) {
159         
160         $direct_links_query->{where}->{'+cub'}->{owner} = $user2_id;
161         $direct_links_query->{where}->{'+cubi'}->{target_user} = $user1_id;
162         return 1 if $e->json_query($direct_links_query)->[0];
163     }
164
165     return 0;
166 }
167
168
169
170 # returns 1 if delegate_user is allowed to perform 'perm' for base_user
171 sub friend_perm_allowed {
172     my($self, $e, $base_user_id, $delegate_user_id, $perm) = @_;
173     return 0 unless $self->confirmed_friends($e, $base_user_id, $delegate_user_id);
174     $perm_check_query->{where} = {
175         '+cubi' => {target_user => $delegate_user_id},
176         '+cub' => {btype => "folks:$perm", owner => $base_user_id}
177     };
178     return 1 if $e->json_query($perm_check_query)->[0];
179     return 0;
180 }
181
182 sub apply_friend_perm {
183     my($self, $e, $base_user_id, $delegate_user_id, $perm) = @_;
184
185     my $bucket = $e->search_container_user_bucket(
186         {owner => $base_user_id, btype => "folks:$perm"})->[0];
187
188     if($bucket) {
189         # is the permission already set?
190         return undef if $e->search_container_user_bucket_item(
191             {bucket => $bucket->id, target_user => $delegate_user_id})->[0];
192
193     } else {
194         # make sure the perm-specific bucket exists for this user
195         $bucket = Fieldmapper::container::user_bucket->new;
196         $bucket->owner($base_user_id);
197         $bucket->btype("folks:$perm");
198         $bucket->name("folks:$perm");
199         $e->create_container_user_bucket($bucket) or return $e->die_event;
200     }
201
202     my $item = Fieldmapper::container::user_bucket_item->new;
203     $item->bucket($bucket->id);
204     $item->target_user($delegate_user_id);
205     $e->create_container_user_bucket_item($item) or return $e->die_event;
206     return undef;
207 }
208
209 23;