3 # Copyright 2013 Rijksmuseum
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
12 # Koha is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
22 use constant KEYLENGTH => 10;
23 use constant SHELVES_URL => '/cgi-bin/koha/opac-shelves.pl?display=privateshelves&viewshelf=';
27 use C4::Auth qw( get_template_and_user );
30 use C4::Output qw( output_html_with_http_headers );
34 use Koha::Virtualshelves;
35 use Koha::Virtualshelfshares;
37 # if virtualshelves is disabled, leave immediately
38 our $query = CGI->new;
39 if ( ! C4::Context->preference('virtualshelves') ) {
40 print $query->redirect("/cgi-bin/koha/errors/404.pl");
44 #-------------------------------------------------------------------------------
46 our ( $op, $template, $loggedinuser, $cookie );
47 $op = $query->param('op') // q{show};
51 ( $template, $loggedinuser, $cookie ) = get_template_and_user(
53 template_name => 'opac-shareshelf.tt',
59 if ( !$pvar->{errcode} ) {
60 show_invite($pvar) if $op eq 'show';
61 show_accept($pvar) if $op eq 'accept';
62 confirm_invite($pvar) if $op eq 'cud-invite';
63 handle_accept($pvar) if $op eq 'cud-accept';
66 load_template_vars($pvar);
67 output_html_with_http_headers $query, $cookie, $template->output, undef, { force_no_caching => 1 };
69 #-------------------------------------------------------------------------------
73 $param->{shelfnumber} = $query->param('shelfnumber') || 0;
74 $param->{addrlist} = $query->param('invite_address') || '';
75 $param->{key} = $query->param('key') || '';
76 $param->{appr_addr} = [];
77 $param->{fail_addr} = [];
78 $param->{errcode} = check_common_errors($param);
81 if ( $param->{addrlist} ) {
82 $param->{addrlist} =~ s|^\s+||;
83 $param->{addrlist} =~ s|\s+$||;
86 #get some list details
88 my $shelfnumber = $param->{shelfnumber};
89 $shelf = Koha::Virtualshelves->find( $shelfnumber ) unless $param->{errcode};
90 $param->{shelfname} = $shelf ? $shelf->shelfname : q||;
91 $param->{owner} = $shelf ? $shelf->owner : -1;
92 $param->{public} = $shelf ? $shelf->public : 0;
97 sub check_common_errors {
99 if ( $op !~ /^(show|accept|cud-invite|cud-accept)$/ ) {
100 return 1; #unknown operation
102 if ( $param->{shelfnumber} !~ /^\d+$/ ) {
103 return 2; #invalid shelf number
105 if ( !C4::Context->preference('OpacAllowSharingPrivateLists') ) {
106 return 3; #not or no longer allowed?
113 check_owner_category($param);
118 return unless check_owner_category($param);
119 process_addrlist($param);
120 if ( @{ $param->{appr_addr} } ) {
121 send_invitekey($param);
125 $param->{errcode} = 6; #not one valid address
131 $template->param( key => $param->{key} );
133 # Main reason for checking the key here is not to expose shelfname
134 # to people who dont have the key
135 my $key = keytostring( stringtokey( $param->{key}, 0 ), 1 );
136 my $shared_shelves = Koha::Virtualshelfshares->search({
137 shelfnumber => $param->{shelfnumber},
140 return if $shared_shelves->count;
141 $param->{errcode} = 7; # not accepted: key invalid or expired
147 my $shelfnumber = $param->{shelfnumber};
148 my $shelf = Koha::Virtualshelves->find( $shelfnumber );
150 # The key for accepting is checked later in Koha::Virtualshelfshare
151 # You must not be the owner and the list must be private
153 $param->{errcode} = 2;
154 } elsif( $shelf->public ) {
155 $param->{errcode} = 5;
156 } elsif( $shelf->owner == $loggedinuser ) {
157 $param->{errcode} = 8;
159 return if $param->{errcode};
161 # Look for shelfnumber and invitekey in shares, expiration check later
162 my $key = keytostring( stringtokey( $param->{key}, 0 ), 1 );
163 my $shared_shelves = Koha::Virtualshelfshares->search({
164 shelfnumber => $param->{shelfnumber},
167 my $shared_shelf = $shared_shelves ? $shared_shelves->next : undef; # we pick the first, but there should only be one
169 if ( $shared_shelf ) {
170 my $is_accepted = eval { $shared_shelf->accept( $key, $loggedinuser ) };
172 notify_owner($param);
173 #redirect to view of this shared list
174 print $query->redirect(
175 -uri => SHELVES_URL . $param->{shelfnumber},
181 $param->{errcode} = 7; # not accepted: key invalid or expired
187 my $patron = Koha::Patrons->find( $param->{owner} );
188 return unless $patron;
190 my $toaddr = $patron->notice_email_address or return;
193 my $letter = C4::Letters::GetPreparedLetter(
195 letter_code => 'SHARE_ACCEPT',
196 branchcode => C4::Context->userenv->{"branch"},
197 lang => $patron->lang,
198 tables => { borrowers => $loggedinuser, },
199 substitute => { listname => $param->{shelfname}, },
202 #send letter to queue
203 C4::Letters::EnqueueLetter(
206 message_transport_type => 'email',
207 from_address => C4::Context->preference('KohaAdminEmailAddress'),
208 to_address => $toaddr,
213 sub process_addrlist {
215 my @temp = split /[,:;]/, $param->{addrlist};
218 foreach my $a (@temp) {
221 if ( Koha::Email->is_valid($a) ) {
228 $param->{appr_addr} = \@appr_addr;
229 $param->{fail_addr} = \@fail_addr;
234 my $fromaddr = C4::Context->preference('KohaAdminEmailAddress');
236 C4::Context->preference('OPACBaseURL')
237 . "/cgi-bin/koha/opac-shareshelf.pl?shelfnumber="
238 . $param->{shelfnumber}
241 #TODO Waiting for the right http or https solution (BZ 8952 a.o.)
243 my @ok; #the addresses that were processed well
244 foreach my $a ( @{ $param->{appr_addr} } ) {
245 my @newkey = randomlist( KEYLENGTH, 64 ); #generate a new key
247 #add a preliminary share record
248 my $shelf = Koha::Virtualshelves->find( $param->{shelfnumber} );
249 my $key = keytostring( \@newkey, 1 );
250 my $is_shared = eval { $shelf->share( $key ); };
251 # TODO Better error handling, catch the exceptions
252 if ( $@ or not $is_shared ) {
253 push @{ $param->{fail_addr} }, $a;
259 my $letter = C4::Letters::GetPreparedLetter(
261 letter_code => 'SHARE_INVITE',
262 branchcode => C4::Context->userenv->{"branch"},
263 lang => 'default', # Not sure how we could use something more useful else here
264 tables => { borrowers => $loggedinuser, },
266 listname => $param->{shelfname},
267 shareurl => $url . keytostring( \@newkey, 0 ),
271 #send letter to queue
272 C4::Letters::EnqueueLetter(
275 message_transport_type => 'email',
276 from_address => $fromaddr,
281 $param->{appr_addr} = \@ok;
284 sub check_owner_category {
287 #sharing user should be the owner
288 #list should be private
289 $param->{errcode} = 4 if $param->{owner} != $loggedinuser;
290 $param->{errcode} = 5 if !$param->{errcode} && $param->{public};
291 return !defined $param->{errcode};
294 sub load_template_vars {
296 my $appr = join '; ', @{ $param->{appr_addr} };
297 my $fail = join '; ', @{ $param->{fail_addr} };
300 errcode => $param->{errcode},
301 shelfnumber => $param->{shelfnumber},
302 shelfname => $param->{shelfname},
303 approvedaddress => $appr,
304 failaddress => $fail,
310 #uses rand, safe enough for this application but not for more sensitive data
311 my ( $length, $base ) = @_;
312 return map { int( rand($base) ); } 1 .. $length;
316 my ( $keyref, $flgBase64 ) = @_;
318 my $alphabet = [ 'A' .. 'Z', 'a' .. 'z', 0 .. 9, '+', '/' ];
319 return join '', map { alphabet_char( $_, $alphabet ); } @$keyref;
321 return join '', map { sprintf( "%02d", $_ ); } @$keyref;
325 my ( $str, $flgBase64 ) = @_;
326 my @temp = split '', $str || '';
328 my $alphabet = [ 'A' .. 'Z', 'a' .. 'z', 0 .. 9, '+', '/' ];
329 return [ map { alphabet_ordinal( $_, $alphabet ); } @temp ];
331 return [] if $str !~ /^\d+$/;
333 for ( my $i = 0 ; $i < @temp - 1 ; $i += 2 ) {
334 push @retval, $temp[$i] * 10 + $temp[ $i + 1 ];
339 sub alphabet_ordinal {
340 my ( $char, $alphabet ) = @_;
341 for my $ord ( 0 .. $#$alphabet ) {
342 return $ord if $char eq $alphabet->[$ord];
344 return ''; #ignore missing chars
349 #reverse operation for ordinal; ignore invalid numbers
350 my ( $num, $alphabet ) = @_;
351 return $num =~ /^\d+$/ && $num <= $#$alphabet ? $alphabet->[$num] : '';