opac/opac-shareshelf.pl

   1 #!/usr/bin/perl
   2
   3 # Copyright 2013 Rijksmuseum
   4 #
   5 # This file is part of Koha.
   6 #
   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.
  11 #
  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.
  16 #
  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>.
  19
  20 use Modern::Perl;
  21
  22 use constant KEYLENGTH     => 10;
  23 use constant SHELVES_URL => '/cgi-bin/koha/opac-shelves.pl?display=privateshelves&viewshelf=';
  24
  25 use CGI qw ( -utf8 );
  26
  27 use C4::Auth qw( get_template_and_user );
  28 use C4::Context;
  29 use C4::Letters;
  30 use C4::Output qw( output_html_with_http_headers );
  31
  32 use Koha::Email;
  33 use Koha::Patrons;
  34 use Koha::Virtualshelves;
  35 use Koha::Virtualshelfshares;
  36
  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");
  41     exit;
  42 }
  43
  44 #-------------------------------------------------------------------------------
  45
  46 our ( $op, $template, $loggedinuser, $cookie );
  47 $op = $query->param('op') // q{show};
  48
  49 my $pvar = _init();
  50
  51 ( $template, $loggedinuser, $cookie ) = get_template_and_user(
  52     {
  53         template_name   => 'opac-shareshelf.tt',
  54         query           => $query,
  55         type            => "opac",
  56     }
  57 );
  58
  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';
  64 }
  65
  66 load_template_vars($pvar);
  67 output_html_with_http_headers $query, $cookie, $template->output, undef, { force_no_caching => 1 };
  68
  69 #-------------------------------------------------------------------------------
  70
  71 sub _init {
  72     my $param = {};
  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);
  79
  80     # trim email address
  81     if ( $param->{addrlist} ) {
  82         $param->{addrlist} =~ s|^\s+||;
  83         $param->{addrlist} =~ s|\s+$||;
  84     }
  85
  86     #get some list details
  87     my $shelf;
  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;
  93
  94     return $param;
  95 }
  96
  97 sub check_common_errors {
  98     my ($param) = @_;
  99     if ( $op !~ /^(show|accept|cud-invite|cud-accept)$/ ) {
 100         return 1;    #unknown operation
 101     }
 102     if ( $param->{shelfnumber} !~ /^\d+$/ ) {
 103         return 2;    #invalid shelf number
 104     }
 105     if ( !C4::Context->preference('OpacAllowSharingPrivateLists') ) {
 106         return 3;    #not or no longer allowed?
 107     }
 108     return;
 109 }
 110
 111 sub show_invite {
 112     my ($param) = @_;
 113     check_owner_category($param);
 114 }
 115
 116 sub confirm_invite {
 117     my ($param) = @_;
 118     return unless check_owner_category($param);
 119     process_addrlist($param);
 120     if ( @{ $param->{appr_addr} } ) {
 121         send_invitekey($param);
 122         $op = 'invited';
 123     }
 124     else {
 125         $param->{errcode} = 6;    #not one valid address
 126     }
 127 }
 128
 129 sub show_accept {
 130     my ($param) = @_;
 131     $template->param( key => $param->{key} );
 132
 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},
 138         invitekey => $key,
 139     });
 140     return if $shared_shelves->count;
 141     $param->{errcode} = 7;    # not accepted: key invalid or expired
 142 }
 143
 144 sub handle_accept {
 145     my ($param) = @_;
 146
 147     my $shelfnumber = $param->{shelfnumber};
 148     my $shelf = Koha::Virtualshelves->find( $shelfnumber );
 149
 150     # The key for accepting is checked later in Koha::Virtualshelfshare
 151     # You must not be the owner and the list must be private
 152     if( !$shelf ) {
 153         $param->{errcode} = 2;
 154     } elsif( $shelf->public ) {
 155         $param->{errcode} = 5;
 156     } elsif( $shelf->owner == $loggedinuser ) {
 157         $param->{errcode} = 8;
 158     }
 159     return if $param->{errcode};
 160
 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},
 165         invitekey => $key,
 166     });
 167     my $shared_shelf = $shared_shelves ? $shared_shelves->next : undef; # we pick the first, but there should only be one
 168
 169     if ( $shared_shelf ) {
 170         my $is_accepted = eval { $shared_shelf->accept( $key, $loggedinuser ) };
 171         if( $is_accepted ) {
 172             notify_owner($param);
 173             #redirect to view of this shared list
 174             print $query->redirect(
 175                 -uri    => SHELVES_URL . $param->{shelfnumber},
 176                 -cookie => $cookie,
 177             );
 178             exit;
 179         }
 180     }
 181     $param->{errcode} = 7; # not accepted: key invalid or expired
 182 }
 183
 184 sub notify_owner {
 185     my ($param) = @_;
 186
 187     my $patron = Koha::Patrons->find( $param->{owner} );
 188     return unless $patron;
 189
 190     my $toaddr = $patron->notice_email_address or return;
 191
 192     #prepare letter
 193     my $letter = C4::Letters::GetPreparedLetter(
 194         module      => 'members',
 195         letter_code => 'SHARE_ACCEPT',
 196         branchcode  => C4::Context->userenv->{"branch"},
 197         lang        => $patron->lang,
 198         tables      => { borrowers => $loggedinuser, },
 199         substitute  => { listname => $param->{shelfname}, },
 200     );
 201
 202     #send letter to queue
 203     C4::Letters::EnqueueLetter(
 204         {
 205             letter                 => $letter,
 206             message_transport_type => 'email',
 207             from_address => C4::Context->preference('KohaAdminEmailAddress'),
 208             to_address   => $toaddr,
 209         }
 210     );
 211 }
 212
 213 sub process_addrlist {
 214     my ($param) = @_;
 215     my @temp = split /[,:;]/, $param->{addrlist};
 216     my @appr_addr;
 217     my @fail_addr;
 218     foreach my $a (@temp) {
 219         $a =~ s/^\s+//;
 220         $a =~ s/\s+$//;
 221         if ( Koha::Email->is_valid($a) ) {
 222             push @appr_addr, $a;
 223         }
 224         else {
 225             push @fail_addr, $a;
 226         }
 227     }
 228     $param->{appr_addr} = \@appr_addr;
 229     $param->{fail_addr} = \@fail_addr;
 230 }
 231
 232 sub send_invitekey {
 233     my ($param) = @_;
 234     my $fromaddr = C4::Context->preference('KohaAdminEmailAddress');
 235     my $url =
 236         C4::Context->preference('OPACBaseURL')
 237       . "/cgi-bin/koha/opac-shareshelf.pl?shelfnumber="
 238       . $param->{shelfnumber}
 239       . "&op=accept&key=";
 240
 241     #TODO Waiting for the right http or https solution (BZ 8952 a.o.)
 242
 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
 246
 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;
 254             next;
 255         }
 256         push @ok, $a;
 257
 258         #prepare letter
 259         my $letter = C4::Letters::GetPreparedLetter(
 260             module      => 'members',
 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, },
 265             substitute  => {
 266                 listname => $param->{shelfname},
 267                 shareurl => $url . keytostring( \@newkey, 0 ),
 268             },
 269         );
 270
 271         #send letter to queue
 272         C4::Letters::EnqueueLetter(
 273             {
 274                 letter                 => $letter,
 275                 message_transport_type => 'email',
 276                 from_address           => $fromaddr,
 277                 to_address             => $a,
 278             }
 279         );
 280     }
 281     $param->{appr_addr} = \@ok;
 282 }
 283
 284 sub check_owner_category {
 285     my ($param) = @_;
 286
 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};
 292 }
 293
 294 sub load_template_vars {
 295     my ($param) = @_;
 296     my $appr = join '; ', @{ $param->{appr_addr} };
 297     my $fail = join '; ', @{ $param->{fail_addr} };
 298     $template->param(
 299         op              => $op,
 300         errcode         => $param->{errcode},
 301         shelfnumber     => $param->{shelfnumber},
 302         shelfname       => $param->{shelfname},
 303         approvedaddress => $appr,
 304         failaddress     => $fail,
 305     );
 306 }
 307
 308 sub randomlist {
 309
 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;
 313 }
 314
 315 sub keytostring {
 316     my ( $keyref, $flgBase64 ) = @_;
 317     if ($flgBase64) {
 318         my $alphabet = [ 'A' .. 'Z', 'a' .. 'z', 0 .. 9, '+', '/' ];
 319         return join '', map { alphabet_char( $_, $alphabet ); } @$keyref;
 320     }
 321     return join '', map { sprintf( "%02d", $_ ); } @$keyref;
 322 }
 323
 324 sub stringtokey {
 325     my ( $str, $flgBase64 ) = @_;
 326     my @temp = split '', $str || '';
 327     if ($flgBase64) {
 328         my $alphabet = [ 'A' .. 'Z', 'a' .. 'z', 0 .. 9, '+', '/' ];
 329         return [ map { alphabet_ordinal( $_, $alphabet ); } @temp ];
 330     }
 331     return [] if $str !~ /^\d+$/;
 332     my @retval;
 333     for ( my $i = 0 ; $i < @temp - 1 ; $i += 2 ) {
 334         push @retval, $temp[$i] * 10 + $temp[ $i + 1 ];
 335     }
 336     return \@retval;
 337 }
 338
 339 sub alphabet_ordinal {
 340     my ( $char, $alphabet ) = @_;
 341     for my $ord ( 0 .. $#$alphabet ) {
 342         return $ord if $char eq $alphabet->[$ord];
 343     }
 344     return '';    #ignore missing chars
 345 }
 346
 347 sub alphabet_char {
 348
 349     #reverse operation for ordinal; ignore invalid numbers
 350     my ( $num, $alphabet ) = @_;
 351     return $num =~ /^\d+$/ && $num <= $#$alphabet ? $alphabet->[$num] : '';
 352 }