Koha/opac/opac-shareshelf.pl
Marcel de Rooy d98bd89094
Bug 34478: Changes for opac-shareshelf
Signed-off-by: Jonathan Druart <jonathan.druart@bugs.koha-community.org>
2024-03-01 10:59:26 +01:00

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] : '';
}