package Koha::Upload;

# Copyright 2007 LibLime, Galen Charlton

# Copyright 2011-2012 BibLibre

# Copyright 2015 Rijksmuseum

#

# This file is part of Koha.

#

# Koha is free software; you can redistribute it and/or modify it under the

# terms of the GNU General Public License as published by the Free Software

# Foundation; either version 3 of the License, or (at your option) any later

# version.

#

# Koha is distributed in the hope that it will be useful, but WITHOUT ANY

# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR

# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.

#

# You should have received a copy of the GNU General Public License along

# with Koha; if not, write to the Free Software Foundation, Inc.,

# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

=head1 NAME

Koha::Upload - Facilitate file uploads (temporary and permanent)

=head1 SYNOPSIS

    use Koha::Upload;

    # add an upload (see tools/upload-file.pl)

    # the public flag allows retrieval via OPAC

    my $upload = Koha::Upload->new( public => 1, category => 'A' );

    my $cgi = $upload->cgi;

    # Do something with $upload->count, $upload->result or $upload->err

    # get some upload records (in staff)

    # Note: use the public flag for OPAC

    my @uploads = Koha::Upload->new->get( term => $term );

    $template->param( uploads => \@uploads );

    # staff download

    my $rec = Koha::Upload->new->get({ id => $id, filehandle => 1 });

    my $fh = $rec->{fh};

    my @hdr = Koha::Upload->httpheaders( $rec->{name} );

    print Encode::encode_utf8( $input->header( @hdr ) );

    while( <$fh> ) { print $_; }

    $fh->close;

    # delete an upload

    my ( $fn ) = Koha::Upload->new->delete({ id => $id });

=head1 DESCRIPTION

    This module is a refactored version of C4::UploadedFile but adds on top

    of that the new functions from report 6874 (Upload plugin in editor).

    That report added module UploadedFiles.pm. This module contains the

    functionality of both.

=head1 METHODS

=cut

use constant KOHA_UPLOAD => 'koha_upload';

use constant BYTES_DIGEST => 2048;

use Modern::Perl;

use CGI; # no utf8 flag, since it may interfere with binary uploads

use Digest::MD5;

use Encode;

use File::Spec;

use IO::File;

use Time::HiRes;

use base qw(Class::Accessor);

use C4::Context;

use C4::Koha;

__PACKAGE__->mk_ro_accessors( qw|| );

=head2 new

    Returns new object based on Class::Accessor.

    Use tmp or temp flag for temporary storage.

    Use public flag to mark uploads as available in OPAC.

    The category parameter is only useful for permanent storage.

=cut

sub new {

    my ( $class, $params ) = @_;

    my $self = $class->SUPER::new();

    $self->_init( $params );

    return $self;

}

=head2 cgi

    Returns CGI object. The CGI hook is used to store the uploaded files.

=cut

sub cgi {

    my ( $self ) = @_;

    # Next call handles the actual upload via CGI hook.

    # The third parameter (0) below means: no CGI temporary storage.

    # Cancelling an upload will make CGI abort the script; no problem,

    # the file(s) without db entry will be removed later.

    my $query = CGI::->new( sub { $self->_hook(@_); }, {}, 0 );

    if( $query ) {

        $self->_done;

        return $query;

    }

}

=head2 count

    Returns number of uploaded files without errors

=cut

sub count {

    my ( $self ) = @_;

    return scalar grep { !exists $self->{files}->{$_}->{errcode} } keys $self->{files};

}

=head2 result

    Returns a string of id's for each successful upload separated by commas.

=cut

sub result {

    my ( $self ) = @_;

    my @a = map { $self->{files}->{$_}->{id} }

        grep { !exists $self->{files}->{$_}->{errcode} }

        keys $self->{files};

    return @a? ( join ',', @a ): undef;

}

=head2 err

    Returns hash with errors in format { file => err, ... }

    Undefined if there are no errors.

=cut

sub err {

    my ( $self ) = @_;

    my $err;

    foreach my $f ( keys $self->{files} ) {

        my $e = $self->{files}->{$f}->{errcode};

        $err->{ $f } = $e if $e;

    }

    return $err;

}

=head2 get

    Returns arrayref of uploaded records (hash) or one uploaded record.

    You can pass id => $id or hashvalue => $hash or term => $term.

    Optional parameter filehandle => 1 returns you a filehandle too.

=cut

sub get {

    my ( $self, $params ) = @_;

    my $temp= $self->_lookup( $params );

    my ( @rv, $res);

    foreach my $r ( @$temp ) {

        undef $res;

        foreach( qw[id hashvalue filesize categorycode public permanent] ) {

            $res->{$_} = $r->{$_};

        }

        $res->{name} = $r->{filename};

        $res->{path} = $self->_full_fname($r);

        if( $res->{path} && -r $res->{path} ) {

            if( $params->{filehandle} ) {

                my $fh = IO::File->new( $res->{path}, "r" );

                $fh->binmode if $fh;

                $res->{fh} = $fh;

            }

            push @rv, $res;

        } else {

            $self->{files}->{ $r->{filename} }->{errcode}=5; #not readable

        }

        last if !wantarray;

    }

    return wantarray? @rv: $res;

}

=head2 delete

    Returns array of deleted filenames or undef.

    Since it now only accepts id as parameter, you should not expect more

    than one filename.

=cut

sub delete {

    my ( $self, $params ) = @_;

    return if !$params->{id};

    my @res;

    my $temp = $self->_lookup({ id => $params->{id} });

    foreach( @$temp ) {

        my $d = $self->_delete( $_ );

        push @res, $d if $d;

    }

    return if !@res;

    return @res;

}

sub DESTROY {

}

# **************  HELPER ROUTINES / CLASS METHODS ******************************

=head2 getCategories

    getCategories returns a list of upload category codes and names

=cut

sub getCategories {

    my ( $class ) = @_;

    my $cats = C4::Koha::GetAuthorisedValues('UPLOAD');

    [ map {{ code => $_->{authorised_value}, name => $_->{lib} }} @$cats ];

}

=head2 httpheaders

    httpheaders returns http headers for a retrievable upload

    Will be extended by report 14282

=cut

sub httpheaders {

    my ( $class, $name ) = @_;

    return (

        '-type'       => 'application/octet-stream',

        '-attachment' => $name,

    );

}

# **************  INTERNAL ROUTINES ********************************************

sub _init {

    my ( $self, $params ) = @_;

    $self->{rootdir} = C4::Context->config('upload_path');

    $self->{tmpdir} = File::Spec->tmpdir;

    $params->{tmp} = $params->{temp} if !exists $params->{tmp};

    $self->{temporary} = $params->{tmp}? 1: 0; #default false

    $self->{category} = $params->{tmp}? KOHA_UPLOAD:

        ( $params->{category} || KOHA_UPLOAD );

    $self->{files} = {};

    $self->{uid} = C4::Context->userenv->{number} if C4::Context->userenv;

    $self->{public} = $params->{public}? 1: undef;

}

sub _fh {

    my ( $self, $filename ) = @_;

    if( $self->{files}->{$filename} ) {

        return $self->{files}->{$filename}->{fh};

    }

}

sub _create_file {

    my ( $self, $filename ) = @_;

    my $fh;

    if( $self->{files}->{$filename} &&

            $self->{files}->{$filename}->{errcode} ) {

        #skip

    } elsif( !$self->{temporary} && !$self->{rootdir} ) {

        $self->{files}->{$filename}->{errcode} = 3; #no rootdir

    } elsif( $self->{temporary} && !$self->{tmpdir} ) {

        $self->{files}->{$filename}->{errcode} = 4; #no tempdir

    } else {

        my $dir = $self->_dir;

        my $fn = $self->{files}->{$filename}->{hash}. '_'. $filename;

        if( -e "$dir/$fn" && @{ $self->_lookup({

          hashvalue => $self->{files}->{$filename}->{hash} }) } ) {

        # if the file exists and it is registered, then set error

            $self->{files}->{$filename}->{errcode} = 1; #already exists

            return;

        }

        $fh = IO::File->new( "$dir/$fn", "w");

        if( $fh ) {

            $fh->binmode;

            $self->{files}->{$filename}->{fh}= $fh;

        } else {

            $self->{files}->{$filename}->{errcode} = 2; #not writable

        }

    }

    return $fh;

}

sub _dir {

    my ( $self ) = @_;

    my $dir = $self->{temporary}? $self->{tmpdir}: $self->{rootdir};

    $dir.= '/'. $self->{category};

    mkdir $dir if !-d $dir;

    return $dir;

}

sub _full_fname {

    my ( $self, $rec ) = @_;

    my $p;

    if( ref $rec ) {

        $p= $rec->{permanent}? $self->{rootdir}: $self->{tmpdir};

        $p.= '/';

        $p.= $rec->{dir}. '/'. $rec->{hashvalue}. '_'. $rec->{filename};

    }

    return $p;

}

sub _hook {

    my ( $self, $filename, $buffer, $bytes_read, $data ) = @_;

    $filename= Encode::decode_utf8( $filename ); # UTF8 chars in filename

    $self->_compute( $filename, $buffer );

    my $fh = $self->_fh( $filename ) // $self->_create_file( $filename );

    print $fh $buffer if $fh;

}

sub _done {

    my ( $self ) = @_;

    $self->{done} = 1;

    foreach my $f ( keys $self->{files} ) {

        my $fh = $self->_fh($f);

        $self->_register( $f, $fh? tell( $fh ): undef )

            if !$self->{files}->{$f}->{errcode};

        $fh->close if $fh;

    }

}

sub _register {

    my ( $self, $filename, $size ) = @_;

    my $dbh= C4::Context->dbh;

    my $sql= "INSERT INTO uploaded_files (hashvalue, filename, dir, filesize,

        owner, categorycode, public, permanent) VALUES (?,?,?,?,?,?,?,?)";

    my @pars= (

        $self->{files}->{$filename}->{hash},

        $filename,

        $self->{category},

        $size,

        $self->{uid},

        $self->{category},

        $self->{public},

        $self->{temporary}? 0: 1,

    );

    $dbh->do( $sql, undef, @pars );

    my $i = $dbh->last_insert_id(undef, undef, 'uploaded_files', undef);

    $self->{files}->{$filename}->{id} = $i if $i;

}

sub _lookup {

    my ( $self, $params ) = @_;

    my $dbh = C4::Context->dbh;

    my $sql = qq|

SELECT id,hashvalue,filename,dir,filesize,categorycode,public,permanent

FROM uploaded_files

    |;

    my @pars;

    if( $params->{id} ) {

        return [] if $params->{id} !~ /^\d+(,\d+)*$/;

        $sql.= "WHERE id IN ($params->{id})";

        @pars = ();

    } elsif( $params->{hashvalue} ) {

        $sql.= "WHERE hashvalue=?";

        @pars = ( $params->{hashvalue} );

    } elsif( $params->{term} ) {

        $sql.= "WHERE (filename LIKE ? OR hashvalue LIKE ?)";

        @pars = ( '%'.$params->{term}.'%', '%'.$params->{term}.'%' );

    } else {

        return [];

    }

    $sql.= $self->{public}? " AND public=1": '';

    $sql.= ' ORDER BY id';

    my $temp= $dbh->selectall_arrayref( $sql, { Slice => {} }, @pars );

    return $temp;

}

sub _delete {

    my ( $self, $rec ) = @_;

    my $dbh = C4::Context->dbh;

    my $sql = 'DELETE FROM uploaded_files WHERE id=?';

    my $file = $self->_full_fname($rec);

    if( !-e $file ) { # we will just delete the record

        # TODO Should we add a trace here for the missing file?

        $dbh->do( $sql, undef, ( $rec->{id} ) );

        return $rec->{filename};

    } elsif( unlink($file) ) {

        $dbh->do( $sql, undef, ( $rec->{id} ) );

        return $rec->{filename};

    }

    $self->{files}->{ $rec->{filename} }->{errcode} = 7;

    #NOTE: errcode=6 is used to report successful delete (see template)

    return;

}

sub _compute {

# Computes hash value when sub hook feeds the first block

# For temporary files, the id is made unique with time

    my ( $self, $name, $block ) = @_;

    if( !$self->{files}->{$name}->{hash} ) {

        my $str = $name. ( $self->{uid} // '0' ).

            ( $self->{temporary}? Time::HiRes::time(): '' ).

            $self->{category}. substr( $block, 0, BYTES_DIGEST );

        # since Digest cannot handle wide chars, we need to encode here

        # there could be a wide char in the filename or the category

        my $h = Digest::MD5::md5_hex( Encode::encode_utf8( $str ) );

        $self->{files}->{$name}->{hash} = $h;

    }

}

=head1 AUTHOR

    Koha Development Team

    Larger parts from Galen Charlton, Julian Maurice and Marcel de Rooy

=cut

1;