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 under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 3 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along
  17 # with Koha; if not, write to the Free Software Foundation, Inc.,
  18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 use strict;
  21 use warnings;
  22
  23 use constant KEYLENGTH => 10;
  24 use constant TEMPLATE_NAME => 'opac-shareshelf.tmpl';
  25
  26 use CGI;
  27 use Email::Valid;
  28
  29 use C4::Auth;
  30 use C4::Context;
  31 use C4::Letters;
  32 use C4::Output;
  33 use C4::VirtualShelves;
  34
  35 #-------------------------------------------------------------------------------
  36
  37 my $pvar= _init( {} );
  38 if(! $pvar->{errcode} ) {
  39     show_invite( $pvar ) if $pvar->{op} eq 'invite';
  40     confirm_invite( $pvar ) if $pvar->{op} eq 'conf_invite';
  41     show_accept( $pvar ) if $pvar->{op} eq 'accept';
  42 }
  43 load_template_vars( $pvar );
  44 output_html_with_http_headers $pvar->{query}, $pvar->{cookie},
  45     $pvar->{template}->output;
  46
  47 #-------------------------------------------------------------------------------
  48
  49 sub _init {
  50     my ($param) = @_;
  51     my $query = new CGI;
  52     $param->{query} = $query;
  53     $param->{shelfnumber} = $query->param('shelfnumber')||0;
  54     $param->{op} = $query->param('op')||'';
  55     $param->{addrlist} = $query->param('invite_address')||'';
  56     $param->{key} = $query->param('key')||'';
  57     $param->{appr_addr} = [];
  58
  59     $param->{errcode} = check_common_errors($param);
  60     load_template($param);
  61     return $param;
  62 }
  63
  64 sub check_common_errors {
  65     my ($param) = @_;
  66     if( $param->{op} !~ /^(invite|conf_invite|accept)$/ ) {
  67         return 1; #no operation specified
  68     }
  69     if( $param->{shelfnumber} !~ /^\d+$/ ) {
  70         return 2; #invalid shelf number
  71     }
  72     if( ! C4::Context->preference('OpacAllowSharingPrivateLists') ) {
  73         return 3; #not or no longer allowed?
  74     }
  75     return;
  76 }
  77
  78 sub show_invite {
  79     my ($param) = @_;
  80     return unless check_owner_category( $param );
  81 }
  82
  83 sub confirm_invite {
  84     my ($param) = @_;
  85     return unless check_owner_category( $param );
  86     process_addrlist( $param );
  87     if( @{$param->{appr_addr}} ) {
  88         send_invitekey( $param );
  89     }
  90     else {
  91         $param->{errcode}=6; #not one valid address
  92     }
  93 }
  94
  95 sub show_accept {
  96     my ($param) = @_;
  97     #TODO Add some code here to accept an invitation (followup report)
  98 }
  99
 100 sub process_addrlist {
 101     my ($param) = @_;
 102     my @temp= split /[,:;]/, $param->{addrlist};
 103     my @appr_addr;
 104     my $fail_addr='';
 105     foreach my $a (@temp) {
 106         $a=~s/^\s+//;
 107         $a=~s/\s+$//;
 108         if( IsEmailAddress($a) ) {
 109             push @appr_addr, $a;
 110         }
 111         else {
 112             $fail_addr.= ($fail_addr? '; ': '').$a;
 113         }
 114     }
 115     $param->{appr_addr}= \@appr_addr;
 116     $param->{fail_addr}= $fail_addr;
 117 }
 118
 119 sub send_invitekey {
 120     my ($param) = @_;
 121     my $fromaddr= C4::Context->preference('KohaAdminEmailAddress');
 122     my $url= 'http://'.C4::Context->preference('OPACBaseURL').
 123         "/cgi-bin/koha/opac-shareshelf.pl?shelfnumber=".
 124         $param->{shelfnumber}."&op=accept&key=";
 125         #TODO Waiting for the right http or https solution (BZ 8952 a.o.)
 126
 127     foreach my $a ( @{$param->{appr_addr}} ) {
 128         my @newkey= randomlist(KEYLENGTH, 64); #generate a new key
 129
 130         #prepare letter
 131         my $letter= C4::Letters::GetPreparedLetter(
 132             module => 'members',
 133             letter_code => 'SHARE_INVITE',
 134             branchcode => C4::Context->userenv->{"branch"},
 135             tables => { borrowers => $param->{loggedinuser}, },
 136             substitute => {
 137                 listname => $param->{shelfname},
 138                 shareurl => $url.keytostring(\@newkey,0),
 139             },
 140         );
 141
 142         #send letter to queue
 143         C4::Letters::EnqueueLetter( {
 144             letter                 => $letter,
 145             message_transport_type => 'email',
 146             from_address           => $fromaddr,
 147             to_address             => $a,
 148         });
 149         #add a preliminary share record
 150         AddShare( $param->{shelfnumber}, keytostring(\@newkey,1));
 151     }
 152 }
 153
 154 sub check_owner_category {
 155     my ($param)= @_;
 156     #TODO candidate for a module?
 157     #need to get back the two different error codes and the shelfname
 158
 159     ( undef, $param->{shelfname}, $param->{owner}, my $category ) =
 160     GetShelf( $param->{shelfnumber} );
 161     $param->{errcode}=4 if $param->{owner}!= $param->{loggedinuser};
 162     $param->{errcode}=5 if !$param->{errcode} && $category!=1;
 163         #should be private
 164     return !defined $param->{errcode};
 165 }
 166
 167 sub load_template {
 168     my ($param)= @_;
 169     ($param->{template}, $param->{loggedinuser}, $param->{cookie} ) =
 170     get_template_and_user( {
 171         template_name   => TEMPLATE_NAME,
 172         query           => $param->{query},
 173         type            => "opac",
 174         authnotrequired => 0, #should be a user
 175     } );
 176 }
 177
 178 sub load_template_vars {
 179     my ($param) = @_;
 180     my $template = $param->{template};
 181     my $str= join '; ', @{$param->{appr_addr}};
 182     $template->param(
 183         errcode         => $param->{errcode},
 184         op              => $param->{op},
 185         shelfnumber     => $param->{shelfnumber},
 186         shelfname       => $param->{shelfname},
 187         approvedaddress => $str,
 188         failaddress     => $param->{fail_addr},
 189     );
 190 }
 191
 192 sub IsEmailAddress {
 193     #TODO candidate for a module?
 194     return Email::Valid->address($_[0])? 1: 0;
 195 }
 196
 197 sub randomlist {
 198 #uses rand, safe enough for this application but not for more sensitive data
 199     my ($length, $base)= @_;
 200     return map { int(rand($base)); } 1..$length;
 201 }
 202
 203 sub keytostring {
 204     my ($keyref, $flgBase64)= @_;
 205     if($flgBase64) {
 206         my $alphabet= [ 'A'..'Z', 'a'..'z', 0..9, '+', '/' ];
 207         return join '', map { alphabet_char($_, $alphabet); } @$keyref;
 208     }
 209     return join '', map { sprintf("%02d",$_); } @$keyref;
 210 }
 211
 212 sub stringtokey {
 213     my ($str, $flgBase64)= @_;
 214     my @temp=split '', $str||'';
 215     if($flgBase64) {
 216         my $alphabet= [ 'A'..'Z', 'a'..'z', 0..9, '+', '/' ];
 217         return map { alphabet_ordinal($_, $alphabet); } @temp;
 218     }
 219     return () if $str!~/^\d+$/;
 220     my @retval;
 221     for(my $i=0; $i<@temp-1; $i+=2) {
 222         push @retval, $temp[$i]*10+$temp[$i+1];
 223     }
 224     return @retval;
 225 }
 226
 227 sub alphabet_ordinal {
 228     my ($char, $alphabet) = @_;
 229     for( 0..$#$alphabet ) {
 230         return $_ if $char eq $alphabet->[$_];
 231     }
 232     return ''; #ignore missing chars
 233 }
 234
 235 sub alphabet_char {
 236 #reverse operation for ordinal; ignore invalid numbers
 237     my ($num, $alphabet) = @_;
 238     return $num =~ /^\d+$/ && $num<=$#$alphabet? $alphabet->[$num]: '';
 239 }