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