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