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 use Koha::UploadedFile;
  79
  80 __PACKAGE__->mk_ro_accessors( qw|| );
  81
  82 =head2 new
  83
  84     Returns new object based on Class::Accessor.
  85     Use tmp or temp flag for temporary storage.
  86     Use public flag to mark uploads as available in OPAC.
  87     The category parameter is only useful for permanent storage.
  88
  89 =cut
  90
  91 sub new {
  92     my ( $class, $params ) = @_;
  93     my $self = $class->SUPER::new();
  94     $self->_init( $params );
  95     return $self;
  96 }
  97
  98 =head2 cgi
  99
 100     Returns CGI object. The CGI hook is used to store the uploaded files.
 101
 102 =cut
 103
 104 sub cgi {
 105     my ( $self ) = @_;
 106
 107     # Next call handles the actual upload via CGI hook.
 108     # The third parameter (0) below means: no CGI temporary storage.
 109     # Cancelling an upload will make CGI abort the script; no problem,
 110     # the file(s) without db entry will be removed later.
 111     my $query = CGI::->new( sub { $self->_hook(@_); }, {}, 0 );
 112     if( $query ) {
 113         $self->_done;
 114         return $query;
 115     }
 116 }
 117
 118 =head2 count
 119
 120     Returns number of uploaded files without errors
 121
 122 =cut
 123
 124 sub count {
 125     my ( $self ) = @_;
 126     return scalar grep { !exists $self->{files}->{$_}->{errcode} } keys %{ $self->{files} };
 127 }
 128
 129 =head2 result
 130
 131     Returns a string of id's for each successful upload separated by commas.
 132
 133 =cut
 134
 135 sub result {
 136     my ( $self ) = @_;
 137     my @a = map { $self->{files}->{$_}->{id} }
 138         grep { !exists $self->{files}->{$_}->{errcode} }
 139         keys %{ $self->{files} };
 140     return @a? ( join ',', @a ): undef;
 141 }
 142
 143 =head2 err
 144
 145     Returns hash with errors in format { file => err, ... }
 146     Undefined if there are no errors.
 147
 148 =cut
 149
 150 sub err {
 151     my ( $self ) = @_;
 152     my $err;
 153     foreach my $f ( keys %{ $self->{files} } ) {
 154         my $e = $self->{files}->{$f}->{errcode};
 155         $err->{ $f } = $e if $e;
 156     }
 157     return $err;
 158 }
 159
 160 =head2 get
 161
 162     Returns arrayref of uploaded records (hash) or one uploaded record.
 163     You can pass id => $id or hashvalue => $hash or term => $term.
 164     Optional parameter filehandle => 1 returns you a filehandle too.
 165
 166 =cut
 167
 168 sub get {
 169     my ( $self, $params ) = @_;
 170     my $temp= $self->_lookup( $params );
 171     my ( @rv, $res);
 172     foreach my $r ( @$temp ) {
 173         undef $res;
 174         foreach( qw[id hashvalue filesize uploadcategorycode public permanent owner] ) {
 175             $res->{$_} = $r->{$_};
 176         }
 177         $res->{name} = $r->{filename};
 178         $res->{path} = $self->_full_fname($r);
 179         if( $res->{path} && -r $res->{path} ) {
 180             if( $params->{filehandle} ) {
 181                 my $fh = IO::File->new( $res->{path}, "r" );
 182                 $fh->binmode if $fh;
 183                 $res->{fh} = $fh;
 184             }
 185             push @rv, $res;
 186         } else {
 187             $self->{files}->{ $r->{filename} }->{errcode}=5; #not readable
 188         }
 189         last if !wantarray;
 190     }
 191     return wantarray? @rv: $res;
 192 }
 193
 194 =head2 delete
 195
 196     Returns array of deleted filenames or undef.
 197     Since it now only accepts id as parameter, you should not expect more
 198     than one filename.
 199
 200 =cut
 201
 202 sub delete {
 203     my ( $self, $params ) = @_;
 204     return if !$params->{id};
 205     my @res;
 206     my $temp = $self->_lookup({ id => $params->{id} });
 207     foreach( @$temp ) {
 208         my $d = $self->_delete( $_ );
 209         push @res, $d if $d;
 210     }
 211     return if !@res;
 212     return @res;
 213 }
 214
 215 =head1 CLASS METHODS
 216
 217 =head2 getCategories
 218
 219     getCategories returns a list of upload category codes and names
 220
 221 =cut
 222
 223 sub getCategories {
 224     my ( $class ) = @_;
 225     my $cats = C4::Koha::GetAuthorisedValues('UPLOAD');
 226     [ map {{ code => $_->{authorised_value}, name => $_->{lib} }} @$cats ];
 227 }
 228
 229 =head2 httpheaders
 230
 231     httpheaders returns http headers for a retrievable upload
 232     Will be extended by report 14282
 233
 234 =cut
 235
 236 sub httpheaders {
 237     my ( $class, $name ) = @_;
 238     return (
 239         '-type'       => 'application/octet-stream',
 240         '-attachment' => $name,
 241     );
 242 }
 243
 244 =head2 allows_add_by
 245
 246     allows_add_by checks if $userid has permission to add uploaded files
 247
 248 =cut
 249
 250 sub allows_add_by {
 251     my ( $class, $userid ) = @_; # do not confuse with borrowernumber
 252     my $flags = [
 253         { tools      => 'upload_general_files' },
 254         { circulate  => 'circulate_remaining_permissions' },
 255         { tools      => 'stage_marc_import' },
 256         { tools      => 'upload_local_cover_images' },
 257     ];
 258     require C4::Auth;
 259     foreach( @$flags ) {
 260         return 1 if C4::Auth::haspermission( $userid, $_ );
 261     }
 262     return;
 263 }
 264
 265 =head1 INTERNAL ROUTINES
 266
 267 =cut
 268
 269 sub _init {
 270     my ( $self, $params ) = @_;
 271
 272     $self->{rootdir} = C4::Context->config('upload_path');
 273     $self->{tmpdir} = File::Spec->tmpdir;
 274
 275     $params->{tmp} = $params->{temp} if !exists $params->{tmp};
 276     $self->{temporary} = $params->{tmp}? 1: 0; #default false
 277     if( $params->{tmp} ) {
 278         my $db =  C4::Context->config('database');
 279         $self->{category} = KOHA_UPLOAD;
 280         $self->{category} =~ s/koha/$db/;
 281     } else {
 282         $self->{category} = $params->{category} || KOHA_UPLOAD;
 283     }
 284
 285     $self->{files} = {};
 286     $self->{uid} = C4::Context->userenv->{number} if C4::Context->userenv;
 287     $self->{public} = $params->{public}? 1: undef;
 288 }
 289
 290 sub _fh {
 291     my ( $self, $filename ) = @_;
 292     if( $self->{files}->{$filename} ) {
 293         return $self->{files}->{$filename}->{fh};
 294     }
 295 }
 296
 297 sub _create_file {
 298     my ( $self, $filename ) = @_;
 299     my $fh;
 300     if( $self->{files}->{$filename} &&
 301             $self->{files}->{$filename}->{errcode} ) {
 302         #skip
 303     } elsif( !$self->{temporary} && !$self->{rootdir} ) {
 304         $self->{files}->{$filename}->{errcode} = 3; #no rootdir
 305     } elsif( $self->{temporary} && !$self->{tmpdir} ) {
 306         $self->{files}->{$filename}->{errcode} = 4; #no tempdir
 307     } else {
 308         my $dir = $self->_dir;
 309         my $fn = $self->{files}->{$filename}->{hash}. '_'. $filename;
 310         if( -e "$dir/$fn" && @{ $self->_lookup({
 311           hashvalue => $self->{files}->{$filename}->{hash} }) } ) {
 312         # if the file exists and it is registered, then set error
 313             $self->{files}->{$filename}->{errcode} = 1; #already exists
 314             return;
 315         }
 316         $fh = IO::File->new( "$dir/$fn", "w");
 317         if( $fh ) {
 318             $fh->binmode;
 319             $self->{files}->{$filename}->{fh}= $fh;
 320         } else {
 321             $self->{files}->{$filename}->{errcode} = 2; #not writable
 322         }
 323     }
 324     return $fh;
 325 }
 326
 327 sub _dir {
 328     my ( $self ) = @_;
 329     my $dir = $self->{temporary}? $self->{tmpdir}: $self->{rootdir};
 330     $dir.= '/'. $self->{category};
 331     mkdir $dir if !-d $dir;
 332     return $dir;
 333 }
 334
 335 sub _full_fname {
 336     my ( $self, $rec ) = @_;
 337     my $p;
 338     if( ref $rec ) {
 339         $p = File::Spec->catfile(
 340             $rec->{permanent}? $self->{rootdir}: $self->{tmpdir},
 341             $rec->{dir},
 342             $rec->{hashvalue}. '_'. $rec->{filename}
 343         );
 344     }
 345     return $p;
 346 }
 347
 348 sub _hook {
 349     my ( $self, $filename, $buffer, $bytes_read, $data ) = @_;
 350     $filename= Encode::decode_utf8( $filename ); # UTF8 chars in filename
 351     $self->_compute( $filename, $buffer );
 352     my $fh = $self->_fh( $filename ) // $self->_create_file( $filename );
 353     print $fh $buffer if $fh;
 354 }
 355
 356 sub _done {
 357     my ( $self ) = @_;
 358     $self->{done} = 1;
 359     foreach my $f ( keys %{ $self->{files} } ) {
 360         my $fh = $self->_fh($f);
 361         $self->_register( $f, $fh? tell( $fh ): undef )
 362             if !$self->{files}->{$f}->{errcode};
 363         $fh->close if $fh;
 364     }
 365 }
 366
 367 sub _register {
 368     my ( $self, $filename, $size ) = @_;
 369     my $rec = Koha::UploadedFile->new({
 370         hashvalue => $self->{files}->{$filename}->{hash},
 371         filename  => $filename,
 372         dir       => $self->{category},
 373         filesize  => $size,
 374         owner     => $self->{uid},
 375         uploadcategorycode => $self->{category},
 376         public    => $self->{public},
 377         permanent => $self->{temporary}? 0: 1,
 378     })->store;
 379     $self->{files}->{$filename}->{id} = $rec->id if $rec;
 380 }
 381
 382 sub _lookup {
 383     my ( $self, $params ) = @_;
 384     my $dbh = C4::Context->dbh;
 385     my $sql = q|
 386 SELECT id,hashvalue,filename,dir,filesize,uploadcategorycode,public,permanent,owner
 387 FROM uploaded_files
 388     |;
 389     my @pars;
 390     if( $params->{id} ) {
 391         return [] if $params->{id} !~ /^\d+(,\d+)*$/;
 392         $sql.= 'WHERE id IN ('.$params->{id}.')';
 393         @pars = ();
 394     } elsif( $params->{hashvalue} ) {
 395         $sql.= 'WHERE hashvalue=?';
 396         @pars = ( $params->{hashvalue} );
 397     } elsif( $params->{term} ) {
 398         $sql.= 'WHERE (filename LIKE ? OR hashvalue LIKE ?)';
 399         @pars = ( '%'.$params->{term}.'%', '%'.$params->{term}.'%' );
 400     } else {
 401         return [];
 402     }
 403     $sql.= $self->{public}? ' AND public=1': '';
 404     $sql.= ' ORDER BY id';
 405     my $temp= $dbh->selectall_arrayref( $sql, { Slice => {} }, @pars );
 406     return $temp;
 407 }
 408
 409 sub _delete {
 410     my ( $self, $rec ) = @_;
 411     my $dbh = C4::Context->dbh;
 412     my $sql = 'DELETE FROM uploaded_files WHERE id=?';
 413     my $file = $self->_full_fname($rec);
 414     if( !-e $file ) { # we will just delete the record
 415         # TODO Should we add a trace here for the missing file?
 416         $dbh->do( $sql, undef, ( $rec->{id} ) );
 417         return $rec->{filename};
 418     } elsif( unlink($file) ) {
 419         $dbh->do( $sql, undef, ( $rec->{id} ) );
 420         return $rec->{filename};
 421     }
 422     $self->{files}->{ $rec->{filename} }->{errcode} = 7;
 423     #NOTE: errcode=6 is used to report successful delete (see template)
 424     return;
 425 }
 426
 427 sub _compute {
 428 # Computes hash value when sub hook feeds the first block
 429 # For temporary files, the id is made unique with time
 430     my ( $self, $name, $block ) = @_;
 431     if( !$self->{files}->{$name}->{hash} ) {
 432         my $str = $name. ( $self->{uid} // '0' ).
 433             ( $self->{temporary}? Time::HiRes::time(): '' ).
 434             $self->{category}. substr( $block, 0, BYTES_DIGEST );
 435         # since Digest cannot handle wide chars, we need to encode here
 436         # there could be a wide char in the filename or the category
 437         my $h = Digest::MD5::md5_hex( Encode::encode_utf8( $str ) );
 438         $self->{files}->{$name}->{hash} = $h;
 439     }
 440 }
 441
 442 =head1 AUTHOR
 443
 444     Koha Development Team
 445     Larger parts from Galen Charlton, Julian Maurice and Marcel de Rooy
 446
 447 =cut
 448
 449 1;