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