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 2 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
  25 use CGI;
  26 use Email::Valid;
  27
  28 use C4::Auth;
  29 use C4::Context;
  30 use C4::Letters;
  31 use C4::Output;
  32 use C4::VirtualShelves;
  33
  34 #-------------------------------------------------------------------------------
  35
  36 my $query= new CGI;
  37 my ($shelfname, $owner);
  38 my ($template, $loggedinuser, $cookie);
  39 my $errcode=0;
  40 my (@addr, $fail_addr, @newkey);
  41 my @base64alphabet= ('A'..'Z', 'a'..'z', 0..9, '+', '/');
  42
  43 my $shelfnumber= $query->param('shelfnumber')||0;
  44 my $op= $query->param('op')||'';
  45 my $addrlist= $query->param('invite_address')||'';
  46 my $key= $query->param('key')||'';
  47
  48 #-------------------------------------------------------------------------------
  49
  50 check_common_errors();
  51 load_template("opac-shareshelf.tmpl");
  52 if($errcode) {
  53     #nothing to do
  54 }
  55 elsif($op eq 'invite') {
  56     show_invite();
  57 }
  58 elsif($op eq 'conf_invite') {
  59     confirm_invite();
  60 }
  61 elsif($op eq 'accept') {
  62     show_accept();
  63 }
  64 load_template_vars();
  65 output_html_with_http_headers $query, $cookie, $template->output;
  66
  67 #-------------------------------------------------------------------------------
  68
  69 sub check_common_errors {
  70     if($op!~/^(invite|conf_invite|accept)$/) {
  71         $errcode=1; #no operation specified
  72         return;
  73     }
  74     if($shelfnumber!~/^\d+$/) {
  75         $errcode=2; #invalid shelf number
  76         return;
  77     }
  78     if(!C4::Context->preference('OpacAllowSharingPrivateLists')) {
  79         $errcode=3; #not or no longer allowed?
  80         return;
  81     }
  82 }
  83
  84 sub show_invite {
  85     return unless check_owner_category();
  86 }
  87
  88 sub confirm_invite {
  89     return unless check_owner_category();
  90     process_addrlist();
  91     if(@addr) {
  92         send_invitekey();
  93     }
  94     else {
  95         $errcode=6; #not one valid address
  96     }
  97 }
  98
  99 sub show_accept {
 100     #TODO Add some code here to accept an invitation (followup report)
 101 }
 102
 103 sub process_addrlist {
 104     my @temp= split /[,:;]/, $addrlist;
 105     $fail_addr='';
 106     foreach my $a (@temp) {
 107         $a=~s/^\s+//;
 108         $a=~s/\s+$//;
 109         if(IsEmailAddress($a)) {
 110             push @addr, $a;
 111         }
 112         else {
 113             $fail_addr.= ($fail_addr? '; ': '').$a;
 114         }
 115     }
 116 }
 117
 118 sub send_invitekey {
 119     my $fromaddr= C4::Context->preference('KohaAdminEmailAddress');
 120     my $url= 'http://'.C4::Context->preference('OPACBaseURL');
 121     $url.= "/cgi-bin/koha/opac-shareshelf.pl?shelfnumber=$shelfnumber";
 122     $url.= "&op=accept&key=";
 123         #FIXME Waiting for the right http or https solution (BZ 8952 a.o.)
 124
 125     foreach my $a (@addr) {
 126         @newkey=randomlist(KEYLENGTH, 64); #generate a new key
 127
 128         #prepare letter
 129         my $letter= C4::Letters::GetPreparedLetter(
 130             module => 'members',
 131             letter_code => 'SHARE_INVITE',
 132             branchcode => C4::Context->userenv->{"branch"},
 133             tables => { borrowers => $loggedinuser, },
 134             substitute => {
 135                 listname => $shelfname,
 136                 shareurl => $url.keytostring(\@newkey,0),
 137             },
 138         );
 139
 140         #send letter to queue
 141         C4::Letters::EnqueueLetter( {
 142             letter                 => $letter,
 143             message_transport_type => 'email',
 144             from_address           => $fromaddr,
 145             to_address             => $a,
 146         });
 147         #add a preliminary share record
 148         AddShare($shelfnumber,keytostring(\@newkey,1));
 149     }
 150 }
 151
 152 sub check_owner_category {
 153     #FIXME candidate for a module? what held me back is: getting back the two different error codes and the shelfname
 154     (undef,$shelfname,$owner,my $category)= GetShelf($shelfnumber);
 155     $errcode=4 if $owner!= $loggedinuser; #should be owner
 156     $errcode=5 if !$errcode && $category!=1; #should be private
 157     return $errcode==0;
 158 }
 159
 160 sub load_template {
 161     my ($file)= @_;
 162     ($template, $loggedinuser, $cookie)= get_template_and_user({
 163         template_name   => $file,
 164         query           => $query,
 165         type            => "opac",
 166         authnotrequired => 0, #should be a user
 167     });
 168 }
 169
 170 sub load_template_vars {
 171     $template->param(
 172         errcode         => $errcode,
 173         op              => $op,
 174         shelfnumber     => $shelfnumber,
 175         shelfname       => $shelfname,
 176         approvedaddress => (join '; ', @addr),
 177         failaddress     => $fail_addr,
 178     );
 179 }
 180
 181 sub IsEmailAddress {
 182     #FIXME candidate for a module?
 183     return Email::Valid->address($_[0])? 1: 0;
 184 }
 185
 186 sub randomlist {
 187 #uses rand, safe enough for this application but not for more sensitive data
 188     my ($length, $base)= @_;
 189     return map { int(rand($base)); } 1..$length;
 190 }
 191
 192 sub keytostring {
 193     my ($keyref, $flgBase64)= @_;
 194     if($flgBase64) {
 195         return join '', map { base64chr($_); } @$keyref;
 196     }
 197     return join '', map { sprintf("%02d",$_); } @$keyref;
 198 }
 199
 200 sub stringtokey {
 201     my ($str, $flgBase64)= @_;
 202     my @temp=split '', $str||'';
 203     if($flgBase64) {
 204         return map { base64ord($_); } @temp;
 205     }
 206     return () if $str!~/^\d+$/;
 207     my @retval;
 208     for(my $i=0; $i<@temp-1; $i+=2) {
 209         push @retval, $temp[$i]*10+$temp[$i+1];
 210     }
 211     return @retval;
 212 }
 213
 214 sub base64ord { #base64 ordinal
 215     my ($char)=@_;
 216     return 0 -ord('A')+ord($char) if $char=~/[A-Z]/;
 217     return 26-ord('a')+ord($char) if $char=~/[a-z]/;
 218     return 52-ord('0')+ord($char) if $char=~/[0-9]/;
 219     return 62 if $char eq '+';
 220     return 63 if $char eq '/';
 221     return;
 222 }
 223
 224 sub base64chr { #reverse operation for ord
 225     return $_[0]=~/^\d+$/ && $_[0]<64? $base64alphabet[$_[0]]: undef;
 226 }