Koha/Upload.pm

   1 package Koha::Upload;
   2
   3 # Copyright 2007 LibLime, Galen Charlton
   4 # Copyright 2011-2012 BibLibre
   5 # Copyright 2015 Rijksmuseum
   6 #
   7 # This file is part of Koha.
   8 #
   9 # Koha is free software; you can redistribute it and/or modify it under the
  10 # terms of the GNU General Public License as published by the Free Software
  11 # Foundation; either version 3 of the License, or (at your option) any later
  12 # version.
  13 #
  14 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  15 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  16 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License along
  19 # with Koha; if not, write to the Free Software Foundation, Inc.,
  20 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  21
  22 =head1 NAME
  23
  24 Koha::Upload - Facilitate file uploads (temporary and permanent)
  25
  26 =head1 SYNOPSIS
  27
  28     use Koha::Upload;
  29
  30     # add an upload (see tools/upload-file.pl)
  31     # the public flag allows retrieval via OPAC
  32     my $upload = Koha::Upload->new( public => 1, category => 'A' );
  33     my $cgi = $upload->cgi;
  34     # Do something with $upload->count, $upload->result or $upload->err
  35
  36     # get some upload records (in staff)
  37     # Note: use the public flag for OPAC
  38     my @uploads = Koha::Upload->new->get( term => $term );
  39     $template->param( uploads => \@uploads );
  40
  41     # staff download
  42     my $rec = Koha::Upload->new->get({ id => $id, filehandle => 1 });
  43     my $fh = $rec->{fh};
  44     my @hdr = Koha::Upload->httpheaders( $rec->{name} );
  45     print Encode::encode_utf8( $input->header( @hdr ) );
  46     while( <$fh> ) { print $_; }
  47     $fh->close;
  48
  49     # delete an upload
  50     my ( $fn ) = Koha::Upload->new->delete({ id => $id });
  51
  52 =head1 DESCRIPTION
  53
  54     This module is a refactored version of C4::UploadedFile but adds on top
  55     of that the new functions from report 6874 (Upload plugin in editor).
  56     That report added module UploadedFiles.pm. This module contains the
  57     functionality of both.
  58
  59 =head1 METHODS
  60
  61 =cut
  62
  63 use constant KOHA_UPLOAD => 'koha_upload';
  64 use constant BYTES_DIGEST => 2048;
  65
  66 use Modern::Perl;
  67 use CGI; # no utf8 flag, since it may interfere with binary uploads
  68 use Digest::MD5;
  69 use Encode;
  70 use File::Spec;
  71 use IO::File;
  72 use Time::HiRes;
  73
  74 use base qw(Class::Accessor);
  75
  76 use C4::Context;
  77 use C4::Koha;
  78
  79 __PACKAGE__->mk_ro_accessors( qw|| );
  80
  81 =head2 new
  82
  83     Returns new object based on Class::Accessor.
  84     Use tmp or temp flag for temporary storage.
  85     Use public flag to mark uploads as available in OPAC.
  86     The category parameter is only useful for permanent storage.
  87
  88 =cut
  89
  90 sub new {
  91     my ( $class, $params ) = @_;
  92     my $self = $class->SUPER::new();
  93     $self->_init( $params );
  94     return $self;
  95 }
  96
  97 =head2 cgi
  98
  99     Returns CGI object. The CGI hook is used to store the uploaded files.
 100
 101 =cut
 102
 103 sub cgi {
 104     my ( $self ) = @_;
 105
 106     # Next call handles the actual upload via CGI hook.
 107     # The third parameter (0) below means: no CGI temporary storage.
 108     # Cancelling an upload will make CGI abort the script; no problem,
 109     # the file(s) without db entry will be removed later.
 110     my $query = CGI::->new( sub { $self->_hook(@_); }, {}, 0 );
 111     if( $query ) {
 112         $self->_done;
 113         return $query;
 114     }
 115 }
 116
 117 =head2 count
 118
 119     Returns number of uploaded files without errors
 120
 121 =cut
 122
 123 sub count {
 124     my ( $self ) = @_;
 125     return scalar grep { !exists $self->{files}->{$_}->{errcode} } keys %{ $self->{files} };
 126 }
 127
 128 =head2 result
 129
 130     Returns a string of id's for each successful upload separated by commas.
 131
 132 =cut
 133
 134 sub result {
 135     my ( $self ) = @_;
 136     my @a = map { $self->{files}->{$_}->{id} }
 137         grep { !exists $self->{files}->{$_}->{errcode} }
 138         keys %{ $self->{files} };
 139     return @a? ( join ',', @a ): undef;
 140 }
 141
 142 =head2 err
 143
 144     Returns hash with errors in format { file => err, ... }
 145     Undefined if there are no errors.
 146
 147 =cut
 148
 149 sub err {
 150     my ( $self ) = @_;
 151     my $err;
 152     foreach my $f ( keys %{ $self->{files} } ) {
 153         my $e = $self->{files}->{$f}->{errcode};
 154         $err->{ $f } = $e if $e;
 155     }
 156     return $err;
 157 }
 158
 159 =head2 get
 160
 161     Returns arrayref of uploaded records (hash) or one uploaded record.
 162     You can pass id => $id or hashvalue => $hash or term => $term.
 163     Optional parameter filehandle => 1 returns you a filehandle too.
 164
 165 =cut
 166
 167 sub get {
 168     my ( $self, $params ) = @_;
 169     my $temp= $self->_lookup( $params );
 170     my ( @rv, $res);
 171     foreach my $r ( @$temp ) {
 172         undef $res;
 173         foreach( qw[id hashvalue filesize uploadcategorycode public permanent] ) {
 174             $res->{$_} = $r->{$_};
 175         }
 176         $res->{name} = $r->{filename};
 177         $res->{path} = $self->_full_fname($r);
 178         if( $res->{path} && -r $res->{path} ) {
 179             if( $params->{filehandle} ) {
 180                 my $fh = IO::File->new( $res->{path}, "r" );
 181                 $fh->binmode if $fh;
 182                 $res->{fh} = $fh;
 183             }
 184             push @rv, $res;
 185         } else {
 186             $self->{files}->{ $r->{filename} }->{errcode}=5; #not readable
 187         }
 188         last if !wantarray;
 189     }
 190     return wantarray? @rv: $res;
 191 }
 192
 193 =head2 delete
 194
 195     Returns array of deleted filenames or undef.
 196     Since it now only accepts id as parameter, you should not expect more
 197     than one filename.
 198
 199 =cut
 200
 201 sub delete {
 202     my ( $self, $params ) = @_;
 203     return if !$params->{id};
 204     my @res;
 205     my $temp = $self->_lookup({ id => $params->{id} });
 206     foreach( @$temp ) {
 207         my $d = $self->_delete( $_ );
 208         push @res, $d if $d;
 209     }
 210     return if !@res;
 211     return @res;
 212 }
 213
 214 =head1 CLASS METHODS
 215
 216 =head2 getCategories
 217
 218     getCategories returns a list of upload category codes and names
 219
 220 =cut
 221
 222 sub getCategories {
 223     my ( $class ) = @_;
 224     my $cats = C4::Koha::GetAuthorisedValues('UPLOAD');
 225     [ map {{ code => $_->{authorised_value}, name => $_->{lib} }} @$cats ];
 226 }
 227
 228 =head2 httpheaders
 229
 230     httpheaders returns http headers for a retrievable upload
 231     Will be extended by report 14282
 232
 233 =cut
 234
 235 sub httpheaders {
 236     my ( $class, $name ) = @_;
 237     return (
 238         '-type'       => 'application/octet-stream',
 239         '-attachment' => $name,
 240     );
 241 }
 242
 243 =head1 INTERNAL ROUTINES
 244
 245 =cut
 246
 247 sub _init {
 248     my ( $self, $params ) = @_;
 249
 250     $self->{rootdir} = C4::Context->config('upload_path');
 251     $self->{tmpdir} = File::Spec->tmpdir;
 252
 253     $params->{tmp} = $params->{temp} if !exists $params->{tmp};
 254     $self->{temporary} = $params->{tmp}? 1: 0; #default false
 255     if( $params->{tmp} ) {
 256         my $db =  C4::Context->config('database');
 257         $self->{category} = KOHA_UPLOAD;
 258         $self->{category} =~ s/koha/$db/;
 259     } else {
 260         $self->{category} = $params->{category} || KOHA_UPLOAD;
 261     }
 262
 263     $self->{files} = {};
 264     $self->{uid} = C4::Context->userenv->{number} if C4::Context->userenv;
 265     $self->{public} = $params->{public}? 1: undef;
 266 }
 267
 268 sub _fh {
 269     my ( $self, $filename ) = @_;
 270     if( $self->{files}->{$filename} ) {
 271         return $self->{files}->{$filename}->{fh};
 272     }
 273 }
 274
 275 sub _create_file {
 276     my ( $self, $filename ) = @_;
 277     my $fh;
 278     if( $self->{files}->{$filename} &&
 279             $self->{files}->{$filename}->{errcode} ) {
 280         #skip
 281     } elsif( !$self->{temporary} && !$self->{rootdir} ) {
 282         $self->{files}->{$filename}->{errcode} = 3; #no rootdir
 283     } elsif( $self->{temporary} && !$self->{tmpdir} ) {
 284         $self->{files}->{$filename}->{errcode} = 4; #no tempdir
 285     } else {
 286         my $dir = $self->_dir;
 287         my $fn = $self->{files}->{$filename}->{hash}. '_'. $filename;
 288         if( -e "$dir/$fn" && @{ $self->_lookup({
 289           hashvalue => $self->{files}->{$filename}->{hash} }) } ) {
 290         # if the file exists and it is registered, then set error
 291             $self->{files}->{$filename}->{errcode} = 1; #already exists
 292             return;
 293         }
 294         $fh = IO::File->new( "$dir/$fn", "w");
 295         if( $fh ) {
 296             $fh->binmode;
 297             $self->{files}->{$filename}->{fh}= $fh;
 298         } else {
 299             $self->{files}->{$filename}->{errcode} = 2; #not writable
 300         }
 301     }
 302     return $fh;
 303 }
 304
 305 sub _dir {
 306     my ( $self ) = @_;
 307     my $dir = $self->{temporary}? $self->{tmpdir}: $self->{rootdir};
 308     $dir.= '/'. $self->{category};
 309     mkdir $dir if !-d $dir;
 310     return $dir;
 311 }
 312
 313 sub _full_fname {
 314     my ( $self, $rec ) = @_;
 315     my $p;
 316     if( ref $rec ) {
 317         $p = File::Spec->catfile(
 318             $rec->{permanent}? $self->{rootdir}: $self->{tmpdir},
 319             $rec->{dir},
 320             $rec->{hashvalue}. '_'. $rec->{filename}
 321         );
 322     }
 323     return $p;
 324 }
 325
 326 sub _hook {
 327     my ( $self, $filename, $buffer, $bytes_read, $data ) = @_;
 328     $filename= Encode::decode_utf8( $filename ); # UTF8 chars in filename
 329     $self->_compute( $filename, $buffer );
 330     my $fh = $self->_fh( $filename ) // $self->_create_file( $filename );
 331     print $fh $buffer if $fh;
 332 }
 333
 334 sub _done {
 335     my ( $self ) = @_;
 336     $self->{done} = 1;
 337     foreach my $f ( keys %{ $self->{files} } ) {
 338         my $fh = $self->_fh($f);
 339         $self->_register( $f, $fh? tell( $fh ): undef )
 340             if !$self->{files}->{$f}->{errcode};
 341         $fh->close if $fh;
 342     }
 343 }
 344
 345 sub _register {
 346     my ( $self, $filename, $size ) = @_;
 347     my $dbh= C4::Context->dbh;
 348     my $sql= 'INSERT INTO uploaded_files (hashvalue, filename, dir, filesize,
 349         owner, uploadcategorycode, public, permanent) VALUES (?,?,?,?,?,?,?,?)';
 350     my @pars= (
 351         $self->{files}->{$filename}->{hash},
 352         $filename,
 353         $self->{category},
 354         $size,
 355         $self->{uid},
 356         $self->{category},
 357         $self->{public},
 358         $self->{temporary}? 0: 1,
 359     );
 360     $dbh->do( $sql, undef, @pars );
 361     my $i = $dbh->last_insert_id(undef, undef, 'uploaded_files', undef);
 362     $self->{files}->{$filename}->{id} = $i if $i;
 363 }
 364
 365 sub _lookup {
 366     my ( $self, $params ) = @_;
 367     my $dbh = C4::Context->dbh;
 368     my $sql = q|
 369 SELECT id,hashvalue,filename,dir,filesize,uploadcategorycode,public,permanent
 370 FROM uploaded_files
 371     |;
 372     my @pars;
 373     if( $params->{id} ) {
 374         return [] if $params->{id} !~ /^\d+(,\d+)*$/;
 375         $sql.= 'WHERE id IN ('.$params->{id}.')';
 376         @pars = ();
 377     } elsif( $params->{hashvalue} ) {
 378         $sql.= 'WHERE hashvalue=?';
 379         @pars = ( $params->{hashvalue} );
 380     } elsif( $params->{term} ) {
 381         $sql.= 'WHERE (filename LIKE ? OR hashvalue LIKE ?)';
 382         @pars = ( '%'.$params->{term}.'%', '%'.$params->{term}.'%' );
 383     } else {
 384         return [];
 385     }
 386     $sql.= $self->{public}? ' AND public=1': '';
 387     $sql.= ' ORDER BY id';
 388     my $temp= $dbh->selectall_arrayref( $sql, { Slice => {} }, @pars );
 389     return $temp;
 390 }
 391
 392 sub _delete {
 393     my ( $self, $rec ) = @_;
 394     my $dbh = C4::Context->dbh;
 395     my $sql = 'DELETE FROM uploaded_files WHERE id=?';
 396     my $file = $self->_full_fname($rec);
 397     if( !-e $file ) { # we will just delete the record
 398         # TODO Should we add a trace here for the missing file?
 399         $dbh->do( $sql, undef, ( $rec->{id} ) );
 400         return $rec->{filename};
 401     } elsif( unlink($file) ) {
 402         $dbh->do( $sql, undef, ( $rec->{id} ) );
 403         return $rec->{filename};
 404     }
 405     $self->{files}->{ $rec->{filename} }->{errcode} = 7;
 406     #NOTE: errcode=6 is used to report successful delete (see template)
 407     return;
 408 }
 409
 410 sub _compute {
 411 # Computes hash value when sub hook feeds the first block
 412 # For temporary files, the id is made unique with time
 413     my ( $self, $name, $block ) = @_;
 414     if( !$self->{files}->{$name}->{hash} ) {
 415         my $str = $name. ( $self->{uid} // '0' ).
 416             ( $self->{temporary}? Time::HiRes::time(): '' ).
 417             $self->{category}. substr( $block, 0, BYTES_DIGEST );
 418         # since Digest cannot handle wide chars, we need to encode here
 419         # there could be a wide char in the filename or the category
 420         my $h = Digest::MD5::md5_hex( Encode::encode_utf8( $str ) );
 421         $self->{files}->{$name}->{hash} = $h;
 422     }
 423 }
 424
 425 =head1 AUTHOR
 426
 427     Koha Development Team
 428     Larger parts from Galen Charlton, Julian Maurice and Marcel de Rooy
 429
 430 =cut
 431
 432 1;