352 lines
10 KiB
Perl
Executable file
352 lines
10 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
|
|
# Copyright 2013 Rijksmuseum
|
|
#
|
|
# This file is part of Koha.
|
|
#
|
|
# Koha is free software; you can redistribute it and/or modify it
|
|
# under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 3 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# Koha is distributed in the hope that it will be useful, but
|
|
# WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with Koha; if not, see <http://www.gnu.org/licenses>.
|
|
|
|
use Modern::Perl;
|
|
|
|
use constant KEYLENGTH => 10;
|
|
use constant SHELVES_URL => '/cgi-bin/koha/opac-shelves.pl?display=privateshelves&viewshelf=';
|
|
|
|
use CGI qw ( -utf8 );
|
|
|
|
use C4::Auth qw( get_template_and_user );
|
|
use C4::Context;
|
|
use C4::Letters;
|
|
use C4::Output qw( output_html_with_http_headers );
|
|
|
|
use Koha::Email;
|
|
use Koha::Patrons;
|
|
use Koha::Virtualshelves;
|
|
use Koha::Virtualshelfshares;
|
|
|
|
# if virtualshelves is disabled, leave immediately
|
|
our $query = CGI->new;
|
|
if ( ! C4::Context->preference('virtualshelves') ) {
|
|
print $query->redirect("/cgi-bin/koha/errors/404.pl");
|
|
exit;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
|
|
our ( $op, $template, $loggedinuser, $cookie );
|
|
$op = $query->param('op') // q{show};
|
|
|
|
my $pvar = _init();
|
|
|
|
( $template, $loggedinuser, $cookie ) = get_template_and_user(
|
|
{
|
|
template_name => 'opac-shareshelf.tt',
|
|
query => $query,
|
|
type => "opac",
|
|
}
|
|
);
|
|
|
|
if ( !$pvar->{errcode} ) {
|
|
show_invite($pvar) if $op eq 'show';
|
|
show_accept($pvar) if $op eq 'accept';
|
|
confirm_invite($pvar) if $op eq 'cud-invite';
|
|
handle_accept($pvar) if $op eq 'cud-accept';
|
|
}
|
|
|
|
load_template_vars($pvar);
|
|
output_html_with_http_headers $query, $cookie, $template->output, undef, { force_no_caching => 1 };
|
|
|
|
#-------------------------------------------------------------------------------
|
|
|
|
sub _init {
|
|
my $param = {};
|
|
$param->{shelfnumber} = $query->param('shelfnumber') || 0;
|
|
$param->{addrlist} = $query->param('invite_address') || '';
|
|
$param->{key} = $query->param('key') || '';
|
|
$param->{appr_addr} = [];
|
|
$param->{fail_addr} = [];
|
|
$param->{errcode} = check_common_errors($param);
|
|
|
|
# trim email address
|
|
if ( $param->{addrlist} ) {
|
|
$param->{addrlist} =~ s|^\s+||;
|
|
$param->{addrlist} =~ s|\s+$||;
|
|
}
|
|
|
|
#get some list details
|
|
my $shelf;
|
|
my $shelfnumber = $param->{shelfnumber};
|
|
$shelf = Koha::Virtualshelves->find( $shelfnumber ) unless $param->{errcode};
|
|
$param->{shelfname} = $shelf ? $shelf->shelfname : q||;
|
|
$param->{owner} = $shelf ? $shelf->owner : -1;
|
|
$param->{public} = $shelf ? $shelf->public : 0;
|
|
|
|
return $param;
|
|
}
|
|
|
|
sub check_common_errors {
|
|
my ($param) = @_;
|
|
if ( $op !~ /^(show|accept|cud-invite|cud-accept)$/ ) {
|
|
return 1; #unknown operation
|
|
}
|
|
if ( $param->{shelfnumber} !~ /^\d+$/ ) {
|
|
return 2; #invalid shelf number
|
|
}
|
|
if ( !C4::Context->preference('OpacAllowSharingPrivateLists') ) {
|
|
return 3; #not or no longer allowed?
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub show_invite {
|
|
my ($param) = @_;
|
|
check_owner_category($param);
|
|
}
|
|
|
|
sub confirm_invite {
|
|
my ($param) = @_;
|
|
return unless check_owner_category($param);
|
|
process_addrlist($param);
|
|
if ( @{ $param->{appr_addr} } ) {
|
|
send_invitekey($param);
|
|
$op = 'invited';
|
|
}
|
|
else {
|
|
$param->{errcode} = 6; #not one valid address
|
|
}
|
|
}
|
|
|
|
sub show_accept {
|
|
my ($param) = @_;
|
|
$template->param( key => $param->{key} );
|
|
|
|
# Main reason for checking the key here is not to expose shelfname
|
|
# to people who dont have the key
|
|
my $key = keytostring( stringtokey( $param->{key}, 0 ), 1 );
|
|
my $shared_shelves = Koha::Virtualshelfshares->search({
|
|
shelfnumber => $param->{shelfnumber},
|
|
invitekey => $key,
|
|
});
|
|
return if $shared_shelves->count;
|
|
$param->{errcode} = 7; # not accepted: key invalid or expired
|
|
}
|
|
|
|
sub handle_accept {
|
|
my ($param) = @_;
|
|
|
|
my $shelfnumber = $param->{shelfnumber};
|
|
my $shelf = Koha::Virtualshelves->find( $shelfnumber );
|
|
|
|
# The key for accepting is checked later in Koha::Virtualshelfshare
|
|
# You must not be the owner and the list must be private
|
|
if( !$shelf ) {
|
|
$param->{errcode} = 2;
|
|
} elsif( $shelf->public ) {
|
|
$param->{errcode} = 5;
|
|
} elsif( $shelf->owner == $loggedinuser ) {
|
|
$param->{errcode} = 8;
|
|
}
|
|
return if $param->{errcode};
|
|
|
|
# Look for shelfnumber and invitekey in shares, expiration check later
|
|
my $key = keytostring( stringtokey( $param->{key}, 0 ), 1 );
|
|
my $shared_shelves = Koha::Virtualshelfshares->search({
|
|
shelfnumber => $param->{shelfnumber},
|
|
invitekey => $key,
|
|
});
|
|
my $shared_shelf = $shared_shelves ? $shared_shelves->next : undef; # we pick the first, but there should only be one
|
|
|
|
if ( $shared_shelf ) {
|
|
my $is_accepted = eval { $shared_shelf->accept( $key, $loggedinuser ) };
|
|
if( $is_accepted ) {
|
|
notify_owner($param);
|
|
#redirect to view of this shared list
|
|
print $query->redirect(
|
|
-uri => SHELVES_URL . $param->{shelfnumber},
|
|
-cookie => $cookie,
|
|
);
|
|
exit;
|
|
}
|
|
}
|
|
$param->{errcode} = 7; # not accepted: key invalid or expired
|
|
}
|
|
|
|
sub notify_owner {
|
|
my ($param) = @_;
|
|
|
|
my $patron = Koha::Patrons->find( $param->{owner} );
|
|
return unless $patron;
|
|
|
|
my $toaddr = $patron->notice_email_address or return;
|
|
|
|
#prepare letter
|
|
my $letter = C4::Letters::GetPreparedLetter(
|
|
module => 'members',
|
|
letter_code => 'SHARE_ACCEPT',
|
|
branchcode => C4::Context->userenv->{"branch"},
|
|
lang => $patron->lang,
|
|
tables => { borrowers => $loggedinuser, },
|
|
substitute => { listname => $param->{shelfname}, },
|
|
);
|
|
|
|
#send letter to queue
|
|
C4::Letters::EnqueueLetter(
|
|
{
|
|
letter => $letter,
|
|
message_transport_type => 'email',
|
|
from_address => C4::Context->preference('KohaAdminEmailAddress'),
|
|
to_address => $toaddr,
|
|
}
|
|
);
|
|
}
|
|
|
|
sub process_addrlist {
|
|
my ($param) = @_;
|
|
my @temp = split /[,:;]/, $param->{addrlist};
|
|
my @appr_addr;
|
|
my @fail_addr;
|
|
foreach my $a (@temp) {
|
|
$a =~ s/^\s+//;
|
|
$a =~ s/\s+$//;
|
|
if ( Koha::Email->is_valid($a) ) {
|
|
push @appr_addr, $a;
|
|
}
|
|
else {
|
|
push @fail_addr, $a;
|
|
}
|
|
}
|
|
$param->{appr_addr} = \@appr_addr;
|
|
$param->{fail_addr} = \@fail_addr;
|
|
}
|
|
|
|
sub send_invitekey {
|
|
my ($param) = @_;
|
|
my $fromaddr = C4::Context->preference('KohaAdminEmailAddress');
|
|
my $url =
|
|
C4::Context->preference('OPACBaseURL')
|
|
. "/cgi-bin/koha/opac-shareshelf.pl?shelfnumber="
|
|
. $param->{shelfnumber}
|
|
. "&op=accept&key=";
|
|
|
|
#TODO Waiting for the right http or https solution (BZ 8952 a.o.)
|
|
|
|
my @ok; #the addresses that were processed well
|
|
foreach my $a ( @{ $param->{appr_addr} } ) {
|
|
my @newkey = randomlist( KEYLENGTH, 64 ); #generate a new key
|
|
|
|
#add a preliminary share record
|
|
my $shelf = Koha::Virtualshelves->find( $param->{shelfnumber} );
|
|
my $key = keytostring( \@newkey, 1 );
|
|
my $is_shared = eval { $shelf->share( $key ); };
|
|
# TODO Better error handling, catch the exceptions
|
|
if ( $@ or not $is_shared ) {
|
|
push @{ $param->{fail_addr} }, $a;
|
|
next;
|
|
}
|
|
push @ok, $a;
|
|
|
|
#prepare letter
|
|
my $letter = C4::Letters::GetPreparedLetter(
|
|
module => 'members',
|
|
letter_code => 'SHARE_INVITE',
|
|
branchcode => C4::Context->userenv->{"branch"},
|
|
lang => 'default', # Not sure how we could use something more useful else here
|
|
tables => { borrowers => $loggedinuser, },
|
|
substitute => {
|
|
listname => $param->{shelfname},
|
|
shareurl => $url . keytostring( \@newkey, 0 ),
|
|
},
|
|
);
|
|
|
|
#send letter to queue
|
|
C4::Letters::EnqueueLetter(
|
|
{
|
|
letter => $letter,
|
|
message_transport_type => 'email',
|
|
from_address => $fromaddr,
|
|
to_address => $a,
|
|
}
|
|
);
|
|
}
|
|
$param->{appr_addr} = \@ok;
|
|
}
|
|
|
|
sub check_owner_category {
|
|
my ($param) = @_;
|
|
|
|
#sharing user should be the owner
|
|
#list should be private
|
|
$param->{errcode} = 4 if $param->{owner} != $loggedinuser;
|
|
$param->{errcode} = 5 if !$param->{errcode} && $param->{public};
|
|
return !defined $param->{errcode};
|
|
}
|
|
|
|
sub load_template_vars {
|
|
my ($param) = @_;
|
|
my $appr = join '; ', @{ $param->{appr_addr} };
|
|
my $fail = join '; ', @{ $param->{fail_addr} };
|
|
$template->param(
|
|
op => $op,
|
|
errcode => $param->{errcode},
|
|
shelfnumber => $param->{shelfnumber},
|
|
shelfname => $param->{shelfname},
|
|
approvedaddress => $appr,
|
|
failaddress => $fail,
|
|
);
|
|
}
|
|
|
|
sub randomlist {
|
|
|
|
#uses rand, safe enough for this application but not for more sensitive data
|
|
my ( $length, $base ) = @_;
|
|
return map { int( rand($base) ); } 1 .. $length;
|
|
}
|
|
|
|
sub keytostring {
|
|
my ( $keyref, $flgBase64 ) = @_;
|
|
if ($flgBase64) {
|
|
my $alphabet = [ 'A' .. 'Z', 'a' .. 'z', 0 .. 9, '+', '/' ];
|
|
return join '', map { alphabet_char( $_, $alphabet ); } @$keyref;
|
|
}
|
|
return join '', map { sprintf( "%02d", $_ ); } @$keyref;
|
|
}
|
|
|
|
sub stringtokey {
|
|
my ( $str, $flgBase64 ) = @_;
|
|
my @temp = split '', $str || '';
|
|
if ($flgBase64) {
|
|
my $alphabet = [ 'A' .. 'Z', 'a' .. 'z', 0 .. 9, '+', '/' ];
|
|
return [ map { alphabet_ordinal( $_, $alphabet ); } @temp ];
|
|
}
|
|
return [] if $str !~ /^\d+$/;
|
|
my @retval;
|
|
for ( my $i = 0 ; $i < @temp - 1 ; $i += 2 ) {
|
|
push @retval, $temp[$i] * 10 + $temp[ $i + 1 ];
|
|
}
|
|
return \@retval;
|
|
}
|
|
|
|
sub alphabet_ordinal {
|
|
my ( $char, $alphabet ) = @_;
|
|
for my $ord ( 0 .. $#$alphabet ) {
|
|
return $ord if $char eq $alphabet->[$ord];
|
|
}
|
|
return ''; #ignore missing chars
|
|
}
|
|
|
|
sub alphabet_char {
|
|
|
|
#reverse operation for ordinal; ignore invalid numbers
|
|
my ( $num, $alphabet ) = @_;
|
|
return $num =~ /^\d+$/ && $num <= $#$alphabet ? $alphabet->[$num] : '';
|
|
}
|