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 owner] ) {
 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 =head2 allows_add_by
 244
 245     allows_add_by checks if $userid has permission to add uploaded files
 246
 247 =cut
 248
 249 sub allows_add_by {
 250     my ( $class, $userid ) = @_; # do not confuse with borrowernumber
 251     my $flags = [
 252         { tools      => 'upload_general_files' },
 253         { circulate  => 'circulate_remaining_permissions' },
 254         { tools      => 'stage_marc_import' },
 255         { tools      => 'upload_local_cover_images' },
 256     ];
 257     require C4::Auth;
 258     foreach( @$flags ) {
 259         return 1 if C4::Auth::haspermission( $userid, $_ );
 260     }
 261     return;
 262 }
 263
 264 =head1 INTERNAL ROUTINES
 265
 266 =cut
 267
 268 sub _init {
 269     my ( $self, $params ) = @_;
 270
 271     $self->{rootdir} = C4::Context->config('upload_path');
 272     $self->{tmpdir} = File::Spec->tmpdir;
 273
 274     $params->{tmp} = $params->{temp} if !exists $params->{tmp};
 275     $self->{temporary} = $params->{tmp}? 1: 0; #default false
 276     if( $params->{tmp} ) {
 277         my $db =  C4::Context->config('database');
 278         $self->{category} = KOHA_UPLOAD;
 279         $self->{category} =~ s/koha/$db/;
 280     } else {
 281         $self->{category} = $params->{category} || KOHA_UPLOAD;
 282     }
 283
 284     $self->{files} = {};
 285     $self->{uid} = C4::Context->userenv->{number} if C4::Context->userenv;
 286     $self->{public} = $params->{public}? 1: undef;
 287 }
 288
 289 sub _fh {
 290     my ( $self, $filename ) = @_;
 291     if( $self->{files}->{$filename} ) {
 292         return $self->{files}->{$filename}->{fh};
 293     }
 294 }
 295
 296 sub _create_file {
 297     my ( $self, $filename ) = @_;
 298     my $fh;
 299     if( $self->{files}->{$filename} &&
 300             $self->{files}->{$filename}->{errcode} ) {
 301         #skip
 302     } elsif( !$self->{temporary} && !$self->{rootdir} ) {
 303         $self->{files}->{$filename}->{errcode} = 3; #no rootdir
 304     } elsif( $self->{temporary} && !$self->{tmpdir} ) {
 305         $self->{files}->{$filename}->{errcode} = 4; #no tempdir
 306     } else {
 307         my $dir = $self->_dir;
 308         my $fn = $self->{files}->{$filename}->{hash}. '_'. $filename;
 309         if( -e "$dir/$fn" && @{ $self->_lookup({
 310           hashvalue => $self->{files}->{$filename}->{hash} }) } ) {
 311         # if the file exists and it is registered, then set error
 312             $self->{files}->{$filename}->{errcode} = 1; #already exists
 313             return;
 314         }
 315         $fh = IO::File->new( "$dir/$fn", "w");
 316         if( $fh ) {
 317             $fh->binmode;
 318             $self->{files}->{$filename}->{fh}= $fh;
 319         } else {
 320             $self->{files}->{$filename}->{errcode} = 2; #not writable
 321         }
 322     }
 323     return $fh;
 324 }
 325
 326 sub _dir {
 327     my ( $self ) = @_;
 328     my $dir = $self->{temporary}? $self->{tmpdir}: $self->{rootdir};
 329     $dir.= '/'. $self->{category};
 330     mkdir $dir if !-d $dir;
 331     return $dir;
 332 }
 333
 334 sub _full_fname {
 335     my ( $self, $rec ) = @_;
 336     my $p;
 337     if( ref $rec ) {
 338         $p = File::Spec->catfile(
 339             $rec->{permanent}? $self->{rootdir}: $self->{tmpdir},
 340             $rec->{dir},
 341             $rec->{hashvalue}. '_'. $rec->{filename}
 342         );
 343     }
 344     return $p;
 345 }
 346
 347 sub _hook {
 348     my ( $self, $filename, $buffer, $bytes_read, $data ) = @_;
 349     $filename= Encode::decode_utf8( $filename ); # UTF8 chars in filename
 350     $self->_compute( $filename, $buffer );
 351     my $fh = $self->_fh( $filename ) // $self->_create_file( $filename );
 352     print $fh $buffer if $fh;
 353 }
 354
 355 sub _done {
 356     my ( $self ) = @_;
 357     $self->{done} = 1;
 358     foreach my $f ( keys %{ $self->{files} } ) {
 359         my $fh = $self->_fh($f);
 360         $self->_register( $f, $fh? tell( $fh ): undef )
 361             if !$self->{files}->{$f}->{errcode};
 362         $fh->close if $fh;
 363     }
 364 }
 365
 366 sub _register {
 367     my ( $self, $filename, $size ) = @_;
 368     my $dbh= C4::Context->dbh;
 369     my $sql= 'INSERT INTO uploaded_files (hashvalue, filename, dir, filesize,
 370         owner, uploadcategorycode, public, permanent) VALUES (?,?,?,?,?,?,?,?)';
 371     my @pars= (
 372         $self->{files}->{$filename}->{hash},
 373         $filename,
 374         $self->{category},
 375         $size,
 376         $self->{uid},
 377         $self->{category},
 378         $self->{public},
 379         $self->{temporary}? 0: 1,
 380     );
 381     $dbh->do( $sql, undef, @pars );
 382     my $i = $dbh->last_insert_id(undef, undef, 'uploaded_files', undef);
 383     $self->{files}->{$filename}->{id} = $i if $i;
 384 }
 385
 386 sub _lookup {
 387     my ( $self, $params ) = @_;
 388     my $dbh = C4::Context->dbh;
 389     my $sql = q|
 390 SELECT id,hashvalue,filename,dir,filesize,uploadcategorycode,public,permanent,owner
 391 FROM uploaded_files
 392     |;
 393     my @pars;
 394     if( $params->{id} ) {
 395         return [] if $params->{id} !~ /^\d+(,\d+)*$/;
 396         $sql.= 'WHERE id IN ('.$params->{id}.')';
 397         @pars = ();
 398     } elsif( $params->{hashvalue} ) {
 399         $sql.= 'WHERE hashvalue=?';
 400         @pars = ( $params->{hashvalue} );
 401     } elsif( $params->{term} ) {
 402         $sql.= 'WHERE (filename LIKE ? OR hashvalue LIKE ?)';
 403         @pars = ( '%'.$params->{term}.'%', '%'.$params->{term}.'%' );
 404     } else {
 405         return [];
 406     }
 407     $sql.= $self->{public}? ' AND public=1': '';
 408     $sql.= ' ORDER BY id';
 409     my $temp= $dbh->selectall_arrayref( $sql, { Slice => {} }, @pars );
 410     return $temp;
 411 }
 412
 413 sub _delete {
 414     my ( $self, $rec ) = @_;
 415     my $dbh = C4::Context->dbh;
 416     my $sql = 'DELETE FROM uploaded_files WHERE id=?';
 417     my $file = $self->_full_fname($rec);
 418     if( !-e $file ) { # we will just delete the record
 419         # TODO Should we add a trace here for the missing file?
 420         $dbh->do( $sql, undef, ( $rec->{id} ) );
 421         return $rec->{filename};
 422     } elsif( unlink($file) ) {
 423         $dbh->do( $sql, undef, ( $rec->{id} ) );
 424         return $rec->{filename};
 425     }
 426     $self->{files}->{ $rec->{filename} }->{errcode} = 7;
 427     #NOTE: errcode=6 is used to report successful delete (see template)
 428     return;
 429 }
 430
 431 sub _compute {
 432 # Computes hash value when sub hook feeds the first block
 433 # For temporary files, the id is made unique with time
 434     my ( $self, $name, $block ) = @_;
 435     if( !$self->{files}->{$name}->{hash} ) {
 436         my $str = $name. ( $self->{uid} // '0' ).
 437             ( $self->{temporary}? Time::HiRes::time(): '' ).
 438             $self->{category}. substr( $block, 0, BYTES_DIGEST );
 439         # since Digest cannot handle wide chars, we need to encode here
 440         # there could be a wide char in the filename or the category
 441         my $h = Digest::MD5::md5_hex( Encode::encode_utf8( $str ) );
 442         $self->{files}->{$name}->{hash} = $h;
 443     }
 444 }
 445
 446 =head1 AUTHOR
 447
 448     Koha Development Team
 449     Larger parts from Galen Charlton, Julian Maurice and Marcel de Rooy
 450
 451 =cut
 452
 453 1;