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 TEMPLATE_NAME => 'opac-shareshelf.tt';
  24 use constant SHELVES_URL =>
  25   '/cgi-bin/koha/opac-shelves.pl?display=privateshelves&viewshelf=';
  26
  27 use CGI qw ( -utf8 );
  28
  29 use C4::Auth qw( get_template_and_user );
  30 use C4::Context;
  31 use C4::Letters;
  32 use C4::Output qw( output_html_with_http_headers );
  33
  34 use Koha::Email;
  35 use Koha::Patrons;
  36 use Koha::Virtualshelves;
  37 use Koha::Virtualshelfshares;
  38
  39
  40 # if virtualshelves is disabled, leave immediately
  41 if ( ! C4::Context->preference('virtualshelves') ) {
  42     my $query = CGI->new;
  43     print $query->redirect("/cgi-bin/koha/errors/404.pl");
  44     exit;
  45 }
  46
  47 #-------------------------------------------------------------------------------
  48
  49 my $pvar = _init( {} );
  50 if ( !$pvar->{errcode} ) {
  51     show_invite($pvar)    if $pvar->{op} eq 'invite';
  52     confirm_invite($pvar) if $pvar->{op} eq 'conf_invite';
  53     show_accept($pvar)    if $pvar->{op} eq 'accept';
  54 }
  55 load_template_vars($pvar);
  56 output_html_with_http_headers $pvar->{query}, $pvar->{cookie}, $pvar->{template}->output, undef, { force_no_caching => 1 };
  57
  58 #-------------------------------------------------------------------------------
  59
  60 sub _init {
  61     my ($param) = @_;
  62     my $query = CGI->new;
  63     $param->{query}       = $query;
  64     $param->{shelfnumber} = $query->param('shelfnumber') || 0;
  65     $param->{op}          = $query->param('op') || '';
  66     $param->{addrlist}    = $query->param('invite_address') || '';
  67     $param->{key}         = $query->param('key') || '';
  68     $param->{appr_addr}   = [];
  69     $param->{fail_addr}   = [];
  70     $param->{errcode}     = check_common_errors($param);
  71
  72     # trim email address
  73     if ( $param->{addrlist} ) {
  74         $param->{addrlist} =~ s|^\s+||;
  75         $param->{addrlist} =~ s|\s+$||;
  76     }
  77
  78     #get some list details
  79     my $shelf;
  80     my $shelfnumber = $param->{shelfnumber};
  81     $shelf = Koha::Virtualshelves->find( $shelfnumber ) unless $param->{errcode};
  82     $param->{shelfname} = $shelf ? $shelf->shelfname : q||;
  83     $param->{owner}     = $shelf ? $shelf->owner : -1;
  84     $param->{public}    = $shelf ? $shelf->public : 0;
  85
  86     load_template($param);
  87     return $param;
  88 }
  89
  90 sub check_common_errors {
  91     my ($param) = @_;
  92     if ( $param->{op} !~ /^(invite|conf_invite|accept)$/ ) {
  93         return 1;    #no operation specified
  94     }
  95     if ( $param->{shelfnumber} !~ /^\d+$/ ) {
  96         return 2;    #invalid shelf number
  97     }
  98     if ( !C4::Context->preference('OpacAllowSharingPrivateLists') ) {
  99         return 3;    #not or no longer allowed?
 100     }
 101     return;
 102 }
 103
 104 sub show_invite {
 105     my ($param) = @_;
 106     return unless check_owner_category($param);
 107 }
 108
 109 sub confirm_invite {
 110     my ($param) = @_;
 111     return unless check_owner_category($param);
 112     process_addrlist($param);
 113     if ( @{ $param->{appr_addr} } ) {
 114         send_invitekey($param);
 115     }
 116     else {
 117         $param->{errcode} = 6;    #not one valid address
 118     }
 119 }
 120
 121 sub show_accept {
 122     my ($param) = @_;
 123
 124     my $shelfnumber = $param->{shelfnumber};
 125     my $shelf = Koha::Virtualshelves->find( $shelfnumber );
 126
 127     # The key for accepting is checked later in Koha::Virtualshelfshare
 128     # You must not be the owner and the list must be private
 129     if( !$shelf ) {
 130         $param->{errcode} = 2;
 131     } elsif( $shelf->public ) {
 132         $param->{errcode} = 5;
 133     } elsif( $shelf->owner == $param->{loggedinuser} ) {
 134         $param->{errcode} = 8;
 135     }
 136     return if $param->{errcode};
 137
 138     # Look for shelfnumber and invitekey in shares, expiration check later
 139     my $key = keytostring( stringtokey( $param->{key}, 0 ), 1 );
 140     my $shared_shelves = Koha::Virtualshelfshares->search({
 141         shelfnumber => $param->{shelfnumber},
 142         invitekey => $key,
 143     });
 144     my $shared_shelf = $shared_shelves ? $shared_shelves->next : undef; # we pick the first, but there should only be one
 145
 146     if ( $shared_shelf ) {
 147         my $is_accepted = eval { $shared_shelf->accept( $key, $param->{loggedinuser} ) };
 148         if( $is_accepted ) {
 149             notify_owner($param);
 150             #redirect to view of this shared list
 151             print $param->{query}->redirect(
 152                 -uri    => SHELVES_URL . $param->{shelfnumber},
 153                 -cookie => $param->{cookie}
 154             );
 155             exit;
 156         }
 157     }
 158     $param->{errcode} = 7; # not accepted: key invalid or expired
 159 }
 160
 161 sub notify_owner {
 162     my ($param) = @_;
 163
 164     my $patron = Koha::Patrons->find( $param->{owner} );
 165     return unless $patron;
 166
 167     my $toaddr = $patron->notice_email_address or return;
 168
 169     #prepare letter
 170     my $letter = C4::Letters::GetPreparedLetter(
 171         module      => 'members',
 172         letter_code => 'SHARE_ACCEPT',
 173         branchcode  => C4::Context->userenv->{"branch"},
 174         lang        => $patron->lang,
 175         tables      => { borrowers => $param->{loggedinuser}, },
 176         substitute  => { listname => $param->{shelfname}, },
 177     );
 178
 179     #send letter to queue
 180     C4::Letters::EnqueueLetter(
 181         {
 182             letter                 => $letter,
 183             message_transport_type => 'email',
 184             from_address => C4::Context->preference('KohaAdminEmailAddress'),
 185             to_address   => $toaddr,
 186         }
 187     );
 188 }
 189
 190 sub process_addrlist {
 191     my ($param) = @_;
 192     my @temp = split /[,:;]/, $param->{addrlist};
 193     my @appr_addr;
 194     my @fail_addr;
 195     foreach my $a (@temp) {
 196         $a =~ s/^\s+//;
 197         $a =~ s/\s+$//;
 198         if ( Koha::Email->is_valid($a) ) {
 199             push @appr_addr, $a;
 200         }
 201         else {
 202             push @fail_addr, $a;
 203         }
 204     }
 205     $param->{appr_addr} = \@appr_addr;
 206     $param->{fail_addr} = \@fail_addr;
 207 }
 208
 209 sub send_invitekey {
 210     my ($param) = @_;
 211     my $fromaddr = C4::Context->preference('KohaAdminEmailAddress');
 212     my $url =
 213         C4::Context->preference('OPACBaseURL')
 214       . "/cgi-bin/koha/opac-shareshelf.pl?shelfnumber="
 215       . $param->{shelfnumber}
 216       . "&op=accept&key=";
 217
 218     #TODO Waiting for the right http or https solution (BZ 8952 a.o.)
 219
 220     my @ok;    #the addresses that were processed well
 221     foreach my $a ( @{ $param->{appr_addr} } ) {
 222         my @newkey = randomlist( KEYLENGTH, 64 );    #generate a new key
 223
 224         #add a preliminary share record
 225         my $shelf = Koha::Virtualshelves->find( $param->{shelfnumber} );
 226         my $key = keytostring( \@newkey, 1 );
 227         my $is_shared = eval { $shelf->share( $key ); };
 228         # TODO Better error handling, catch the exceptions
 229         if ( $@ or not $is_shared ) {
 230             push @{ $param->{fail_addr} }, $a;
 231             next;
 232         }
 233         push @ok, $a;
 234
 235         #prepare letter
 236         my $letter = C4::Letters::GetPreparedLetter(
 237             module      => 'members',
 238             letter_code => 'SHARE_INVITE',
 239             branchcode  => C4::Context->userenv->{"branch"},
 240             lang        => 'default', # Not sure how we could use something more useful else here
 241             tables      => { borrowers => $param->{loggedinuser}, },
 242             substitute  => {
 243                 listname => $param->{shelfname},
 244                 shareurl => $url . keytostring( \@newkey, 0 ),
 245             },
 246         );
 247
 248         #send letter to queue
 249         C4::Letters::EnqueueLetter(
 250             {
 251                 letter                 => $letter,
 252                 message_transport_type => 'email',
 253                 from_address           => $fromaddr,
 254                 to_address             => $a,
 255             }
 256         );
 257     }
 258     $param->{appr_addr} = \@ok;
 259 }
 260
 261 sub check_owner_category {
 262     my ($param) = @_;
 263
 264     #sharing user should be the owner
 265     #list should be private
 266     $param->{errcode} = 4 if $param->{owner} != $param->{loggedinuser};
 267     $param->{errcode} = 5 if !$param->{errcode} && $param->{public};
 268     return !defined $param->{errcode};
 269 }
 270
 271 sub load_template {
 272     my ($param) = @_;
 273     ( $param->{template}, $param->{loggedinuser}, $param->{cookie} ) =
 274       get_template_and_user(
 275         {
 276             template_name   => TEMPLATE_NAME,
 277             query           => $param->{query},
 278             type            => "opac",
 279             authnotrequired => 0,                 #should be a user
 280         }
 281       );
 282 }
 283
 284 sub load_template_vars {
 285     my ($param) = @_;
 286     my $template = $param->{template};
 287     my $appr = join '; ', @{ $param->{appr_addr} };
 288     my $fail = join '; ', @{ $param->{fail_addr} };
 289     $template->param(
 290         errcode         => $param->{errcode},
 291         op              => $param->{op},
 292         shelfnumber     => $param->{shelfnumber},
 293         shelfname       => $param->{shelfname},
 294         approvedaddress => $appr,
 295         failaddress     => $fail,
 296     );
 297 }
 298
 299 sub randomlist {
 300
 301     #uses rand, safe enough for this application but not for more sensitive data
 302     my ( $length, $base ) = @_;
 303     return map { int( rand($base) ); } 1 .. $length;
 304 }
 305
 306 sub keytostring {
 307     my ( $keyref, $flgBase64 ) = @_;
 308     if ($flgBase64) {
 309         my $alphabet = [ 'A' .. 'Z', 'a' .. 'z', 0 .. 9, '+', '/' ];
 310         return join '', map { alphabet_char( $_, $alphabet ); } @$keyref;
 311     }
 312     return join '', map { sprintf( "%02d", $_ ); } @$keyref;
 313 }
 314
 315 sub stringtokey {
 316     my ( $str, $flgBase64 ) = @_;
 317     my @temp = split '', $str || '';
 318     if ($flgBase64) {
 319         my $alphabet = [ 'A' .. 'Z', 'a' .. 'z', 0 .. 9, '+', '/' ];
 320         return [ map { alphabet_ordinal( $_, $alphabet ); } @temp ];
 321     }
 322     return [] if $str !~ /^\d+$/;
 323     my @retval;
 324     for ( my $i = 0 ; $i < @temp - 1 ; $i += 2 ) {
 325         push @retval, $temp[$i] * 10 + $temp[ $i + 1 ];
 326     }
 327     return \@retval;
 328 }
 329
 330 sub alphabet_ordinal {
 331     my ( $char, $alphabet ) = @_;
 332     for my $ord ( 0 .. $#$alphabet ) {
 333         return $ord if $char eq $alphabet->[$ord];
 334     }
 335     return '';    #ignore missing chars
 336 }
 337
 338 sub alphabet_char {
 339
 340     #reverse operation for ordinal; ignore invalid numbers
 341     my ( $num, $alphabet ) = @_;
 342     return $num =~ /^\d+$/ && $num <= $#$alphabet ? $alphabet->[$num] : '';
 343 }