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 categorycode 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 sub DESTROY {
 215 }
 216
 217 # **************  HELPER ROUTINES / CLASS METHODS ******************************
 218
 219 =head2 getCategories
 220
 221     getCategories returns a list of upload category codes and names
 222
 223 =cut
 224
 225 sub getCategories {
 226     my ( $class ) = @_;
 227     my $cats = C4::Koha::GetAuthorisedValues('UPLOAD');
 228     [ map {{ code => $_->{authorised_value}, name => $_->{lib} }} @$cats ];
 229 }
 230
 231 =head2 httpheaders
 232
 233     httpheaders returns http headers for a retrievable upload
 234     Will be extended by report 14282
 235
 236 =cut
 237
 238 sub httpheaders {
 239     my ( $class, $name ) = @_;
 240     return (
 241         '-type'       => 'application/octet-stream',
 242         '-attachment' => $name,
 243     );
 244 }
 245
 246 # **************  INTERNAL ROUTINES ********************************************
 247
 248 sub _init {
 249     my ( $self, $params ) = @_;
 250
 251     $self->{rootdir} = C4::Context->config('upload_path');
 252     $self->{tmpdir} = File::Spec->tmpdir;
 253
 254     $params->{tmp} = $params->{temp} if !exists $params->{tmp};
 255     $self->{temporary} = $params->{tmp}? 1: 0; #default false
 256     $self->{category} = $params->{tmp}? KOHA_UPLOAD:
 257         ( $params->{category} || KOHA_UPLOAD );
 258
 259     $self->{files} = {};
 260     $self->{uid} = C4::Context->userenv->{number} if C4::Context->userenv;
 261     $self->{public} = $params->{public}? 1: undef;
 262 }
 263
 264 sub _fh {
 265     my ( $self, $filename ) = @_;
 266     if( $self->{files}->{$filename} ) {
 267         return $self->{files}->{$filename}->{fh};
 268     }
 269 }
 270
 271 sub _create_file {
 272     my ( $self, $filename ) = @_;
 273     my $fh;
 274     if( $self->{files}->{$filename} &&
 275             $self->{files}->{$filename}->{errcode} ) {
 276         #skip
 277     } elsif( !$self->{temporary} && !$self->{rootdir} ) {
 278         $self->{files}->{$filename}->{errcode} = 3; #no rootdir
 279     } elsif( $self->{temporary} && !$self->{tmpdir} ) {
 280         $self->{files}->{$filename}->{errcode} = 4; #no tempdir
 281     } else {
 282         my $dir = $self->_dir;
 283         my $fn = $self->{files}->{$filename}->{hash}. '_'. $filename;
 284         if( -e "$dir/$fn" && @{ $self->_lookup({
 285           hashvalue => $self->{files}->{$filename}->{hash} }) } ) {
 286         # if the file exists and it is registered, then set error
 287             $self->{files}->{$filename}->{errcode} = 1; #already exists
 288             return;
 289         }
 290         $fh = IO::File->new( "$dir/$fn", "w");
 291         if( $fh ) {
 292             $fh->binmode;
 293             $self->{files}->{$filename}->{fh}= $fh;
 294         } else {
 295             $self->{files}->{$filename}->{errcode} = 2; #not writable
 296         }
 297     }
 298     return $fh;
 299 }
 300
 301 sub _dir {
 302     my ( $self ) = @_;
 303     my $dir = $self->{temporary}? $self->{tmpdir}: $self->{rootdir};
 304     $dir.= '/'. $self->{category};
 305     mkdir $dir if !-d $dir;
 306     return $dir;
 307 }
 308
 309 sub _full_fname {
 310     my ( $self, $rec ) = @_;
 311     my $p;
 312     if( ref $rec ) {
 313         $p= $rec->{permanent}? $self->{rootdir}: $self->{tmpdir};
 314         $p.= '/';
 315         $p.= $rec->{dir}. '/'. $rec->{hashvalue}. '_'. $rec->{filename};
 316     }
 317     return $p;
 318 }
 319
 320 sub _hook {
 321     my ( $self, $filename, $buffer, $bytes_read, $data ) = @_;
 322     $filename= Encode::decode_utf8( $filename ); # UTF8 chars in filename
 323     $self->_compute( $filename, $buffer );
 324     my $fh = $self->_fh( $filename ) // $self->_create_file( $filename );
 325     print $fh $buffer if $fh;
 326 }
 327
 328 sub _done {
 329     my ( $self ) = @_;
 330     $self->{done} = 1;
 331     foreach my $f ( keys $self->{files} ) {
 332         my $fh = $self->_fh($f);
 333         $self->_register( $f, $fh? tell( $fh ): undef )
 334             if !$self->{files}->{$f}->{errcode};
 335         $fh->close if $fh;
 336     }
 337 }
 338
 339 sub _register {
 340     my ( $self, $filename, $size ) = @_;
 341     my $dbh= C4::Context->dbh;
 342     my $sql= "INSERT INTO uploaded_files (hashvalue, filename, dir, filesize,
 343         owner, categorycode, public, permanent) VALUES (?,?,?,?,?,?,?,?)";
 344     my @pars= (
 345         $self->{files}->{$filename}->{hash},
 346         $filename,
 347         $self->{category},
 348         $size,
 349         $self->{uid},
 350         $self->{category},
 351         $self->{public},
 352         $self->{temporary}? 0: 1,
 353     );
 354     $dbh->do( $sql, undef, @pars );
 355     my $i = $dbh->last_insert_id(undef, undef, 'uploaded_files', undef);
 356     $self->{files}->{$filename}->{id} = $i if $i;
 357 }
 358
 359 sub _lookup {
 360     my ( $self, $params ) = @_;
 361     my $dbh = C4::Context->dbh;
 362     my $sql = qq|
 363 SELECT id,hashvalue,filename,dir,filesize,categorycode,public,permanent
 364 FROM uploaded_files
 365     |;
 366     my @pars;
 367     if( $params->{id} ) {
 368         return [] if $params->{id} !~ /^\d+(,\d+)*$/;
 369         $sql.= "WHERE id IN ($params->{id})";
 370         @pars = ();
 371     } elsif( $params->{hashvalue} ) {
 372         $sql.= "WHERE hashvalue=?";
 373         @pars = ( $params->{hashvalue} );
 374     } elsif( $params->{term} ) {
 375         $sql.= "WHERE (filename LIKE ? OR hashvalue LIKE ?)";
 376         @pars = ( '%'.$params->{term}.'%', '%'.$params->{term}.'%' );
 377     } else {
 378         return [];
 379     }
 380     $sql.= $self->{public}? " AND public=1": '';
 381     $sql.= ' ORDER BY id';
 382     my $temp= $dbh->selectall_arrayref( $sql, { Slice => {} }, @pars );
 383     return $temp;
 384 }
 385
 386 sub _delete {
 387     my ( $self, $rec ) = @_;
 388     my $dbh = C4::Context->dbh;
 389     my $sql = 'DELETE FROM uploaded_files WHERE id=?';
 390     my $file = $self->_full_fname($rec);
 391     if( !-e $file ) { # we will just delete the record
 392         # TODO Should we add a trace here for the missing file?
 393         $dbh->do( $sql, undef, ( $rec->{id} ) );
 394         return $rec->{filename};
 395     } elsif( unlink($file) ) {
 396         $dbh->do( $sql, undef, ( $rec->{id} ) );
 397         return $rec->{filename};
 398     }
 399     $self->{files}->{ $rec->{filename} }->{errcode} = 7;
 400     #NOTE: errcode=6 is used to report successful delete (see template)
 401     return;
 402 }
 403
 404 sub _compute {
 405 # Computes hash value when sub hook feeds the first block
 406 # For temporary files, the id is made unique with time
 407     my ( $self, $name, $block ) = @_;
 408     if( !$self->{files}->{$name}->{hash} ) {
 409         my $str = $name. ( $self->{uid} // '0' ).
 410             ( $self->{temporary}? Time::HiRes::time(): '' ).
 411             $self->{category}. substr( $block, 0, BYTES_DIGEST );
 412         # since Digest cannot handle wide chars, we need to encode here
 413         # there could be a wide char in the filename or the category
 414         my $h = Digest::MD5::md5_hex( Encode::encode_utf8( $str ) );
 415         $self->{files}->{$name}->{hash} = $h;
 416     }
 417 }
 418
 419 =head1 AUTHOR
 420
 421     Koha Development Team
 422     Larger parts from Galen Charlton, Julian Maurice and Marcel de Rooy
 423
 424 =cut
 425
 426 1;