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