| Line 0
          
      
      
        Link Here | 
          
            
              | 0 | -  | 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 | } |