• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Controller::Roles::DataFile;

use Moose::Role;

use File::Copy;
use File::Path qw(make_path);
use LWP::UserAgent;
use File::Basename;
use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
use IO::All; # rename() gives cryptic error "Can't locate IO/All/Rename.pm in @INC"
             # if target file doesn't exist
use Data::Dumper; # leave on - used by File::Path error handler

#-------------------------------------------------------------------------------
sub data_file_from_url {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    # limit upload to 20MB:
    $CGI::POST_MAX = 20_000 * 1_024; # working but not setting cgi_error ??

    my $url = $self->query->param('url') || return $self->forward('data_file');

    my $rtn_url = $self->query->param('_return') # optional - from referral_sources lookup page
    || $self->query->url . '/resources/data_file'; # warn $rtn_url;

    # needs http(s) prefix:
    unless ($url =~ m!\Ahttp(s?)://!) {
        my $msg  = $self->messages('admin')->{data_file}->{prefix_error};
        my $html = $self->forward( 'data_file', $msg );
        return $self->fill_form($html);
    }

    # expect one of following suffixes:
    my ($suffix) = $url =~ /(zip|csv)\Z/;

    # return to source if no / incorrect suffix:
    if (! $suffix) {
        my $msg  = $self->messages('admin')->{data_file}->{url_error};
        my $html = $self->forward( 'data_file', $msg );
        return $self->fill_form($html);
    }

    # filename for temp file:
    my $temp_file = $self->_path_to_data_files . '/temp.' . $suffix;

    # io($url) > io($temp_file); # IO::All wrapper round LWP::UserAgent - gives error

    my $ua = LWP::UserAgent->new;

    my $response;

    # get the file or give up after 15secs:
	eval {
		local $SIG{ALRM} = sub {
			die 'LWP::UserAgent timeout' . "\n"; # NB \n required
		};
		alarm 15;
		$response = $ua->get( $url, ':content_file' => $temp_file );
		alarm 0;
	};

    unless ($response->is_success) {
        my $html = $self->forward( 'data_file', $response->status_line );
        return $self->fill_form($html);
    }
    # TODO: rest of block almost identical to data_file_upload()
    my $filename;

    # unzip & get filename:
    if ($suffix eq 'zip') {
        $filename = $self->_unzip_file($temp_file); # returns empty on error (sets flash)
    }
    # must be .csv:
    else {
        $filename = $self->_get_filename_from_url($url);
    }

    # delete temp file now:
    io($temp_file)->unlink;

    if (! $filename) { # redirect (flash message set earlier):
        return $self->redirect( $rtn_url );
    }
    # update data file (returns true on success):
    elsif ( $self->_update_file($filename) ) {
        $self->flash( info => $self->messages('admin')->{data_file}->{update_success} );
    }
    else {
        $self->flash( error => $self->messages('admin')->{data_file}->{update_failed} );
    }

    return $self->redirect( $rtn_url );
}

#-------------------------------------------------------------------------------
sub data_file_from_upload {
    my $self = shift; $self->_debug_path($self->get_current_runmode);

    $self->query->param('data_file') || return $self->forward('data_file');

    my $file = $self->query->upload('data_file'); # CGI method

    # expect one of following suffixes:
    my ($suffix) = $file =~ /(zip|csv)\Z/;

    # return to source if no / incorrect suffix:
    if (! $suffix) {
        my $msg  = $self->messages('admin')->{data_file}->{url_error};
        my $html = $self->forward( 'data_file', $msg );
        return $self->fill_form($html);
    }

    my $temp_file = $self->_path_to_data_files . '/temp.' . $suffix;

    { # write to file:
        # Write contents to temp file:
        my $buffer;
        while ( read( $file, $buffer, 16_384 ) ) {
            io($temp_file)->append($buffer);
        }
    }
    # TODO: rest of block almost identical to data_file_url()
    my $filename;

    if ( $suffix eq 'zip' ) {
        $filename = $self->_unzip_file($temp_file); # returns empty on error (sets flash)
    }
    else {
        $filename = $self->_get_filename_from_url($file);
    }

    # delete temp file now:
    io($temp_file)->unlink;

    if (! $filename) { # redirect (flash message set earlier):
        return $self->redirect( $self->query->url . '/resources/data_file' );
    }
    # update data file (returns true on success):
    elsif ( $self->_update_file($filename) ) {
        $self->flash( info => $self->messages('admin')->{data_file}->{update_success} );
    }
    else {
        $self->flash( error => $self->messages('admin')->{data_file}->{update_failed} );
    }

    return $self->redirect( $self->query->url . '/resources/data_file' );
}

#-------------------------------------------------------------------------------
sub load_image_files {
	my ($self, $request) = @_;

    my $dir = $self->_get_destination_dir($request); # warn $dir;

    return unless -d $dir;

    my $contents;

    foreach my $item ( io($dir)->all ) { # warn $item->type;
        next unless $item->type eq 'file';

        # separate images & other files:
        if ( $item->filename =~ /\.(png|jp(e?)g|gif)\Z/i ) {
            push @{ $contents->{images} }, $item->filename;
        }
        else {
            push @{ $contents->{files} }, $item->filename;
        }
    } # warn Dumper $contents;

    return $contents;
}

#-------------------------------------------------------------------------------
sub check_image_file {
	my ($self, $request_id) = @_;

    # get request:
    my $request = $self->model('Request')->get_request($request_id);

	# get the uploaded file from the web page
	my $fh = $self->query->upload('image_file'); # CGI method
	$self->stash( fh => $fh ); # warn $fh;

    my $destination_dir = $self->_get_destination_dir($request->as_tree);

	# get the filename from the full path for naming the image correctly
    if ( $ENV{'HTTP_USER_AGENT'} =~ /MSIE/ ) { # or can't split filename from path
        File::Basename::fileparse_set_fstype('MSWin32');
    }

	my $filename = File::Basename::basename($fh); # warn $filename;
    $self->stash( upload_filename => $filename );
    { # remove any chars that generate malformed url's when loading for file deletion:
        my $re = qr(\+);
        if ( $filename =~ /$re/ ) {
            $filename =~ s/$re/_/g; # warn $filename;
            my $msg = $self->messages('file_upload')->{reserved_chars};
            $self->flash( warning =>  $msg );
        }
    }

    my $file = join '/', $destination_dir, $filename; # warn $file;

	# stash file for later use:
	$self->stash( filename => $file ); # warn $file;

	# returns true if file already exist:
	return ( -e $file ); # if ( -e $file ) { warn 'EXISTS' }
}

#-------------------------------------------------------------------------------
sub upload_image {
	my ($self, $request_id) = @_;

    my $destination_dir = $self->stash->{destination_dir};

	unless (-d $destination_dir) {
        # mode/mask will NOT set 'w' mode on 'group' & 'other'; umask setting
        # overrides this; "umask 002" should allow dirs to be group-writable but doesn't
        make_path($destination_dir, { mode => 0776, error => \my $err });
        return Dumper $err if @$err;
	}

	my $fh = $self->stash->{fh};

    my $file = $self->stash->{filename};

	# write to file:
	if ($^O =~ /MSWin32/) { # doesn't work with read() method
		open(OUT,">$file") or return "cannot open output file $!";
		binmode(OUT);
		while(<$fh>) {
			print OUT $_;
		}
		close(OUT);
	}
   else {
        my $buffer;
        while ( read( $fh, $buffer, 16_384 ) ) {
            io($file)->append($buffer);
        }
    }

    if ( $self->cfg('settings')->{file_upload_history} ) {
        my $filename = $self->stash->{upload_filename};
		my %data = (
			request_id => $request_id,
			action     => "uploaded $filename file",
		);
		$self->model('History')->do_log_action('RequestLabTestHistory', \%data);
    }

	# caller expects any return value to be error:
	return 0;
}

#-------------------------------------------------------------------------------
sub delete_image {
	my ($self, $args) = @_; # warn Dumper $args;

	my $request_data = $args->{request_data};
	my $filename     = $args->{filename};

    my $destination_dir = $self->_get_destination_dir($request_data);

	my $file = $destination_dir . '/' . $filename; # warn $file; return;
	eval { # getting: Can't find a class for method 'unlink'
        io($file)->unlink if -e $file; # warn $file;
    };
    return $@ if $@;
}

#-------------------------------------------------------------------------------
sub slurp_file_contents {
    my ($self, $request, $data_file) = @_;

    my $destination_dir = $self->_get_destination_dir($request);

    my @file_contents = io($destination_dir . '/' . $data_file)->slurp;

    return \@file_contents;
}

#-------------------------------------------------------------------------------
sub process_file_upload {
	my $self = shift;
	my $args = shift; # warn Dumper $args;

	my $target_dir = $args->{target_dir};
	my $filename   = $args->{filename};
	my $src_file   = $args->{src_file};

	use constant BUFFER_SIZE => 16_384;

	my $new_file = join '/', $target_dir, $filename; # warn Dumper $tmp_file;
	$new_file =~ s/\s/_/g; # substitute spaces

    # delete previous file if exists from failed previous invocation or we'll die at $fh stage:
    if (-e $new_file) {
        unlink $new_file || die "Couldn't delete previous $new_file file - $!";
    }

    # Write contents to output file
    my $buffer = undef;
    while ( read( $src_file, $buffer, BUFFER_SIZE ) ) {
		io($new_file)->append($buffer);
    }

	return 1;
}

#-------------------------------------------------------------------------------
sub get_file_by_filetype {
	my ($self, $args) = @_; # warn Dumper $args;

    my $request_id = $args->{request_id};
    my $file_type  = $args->{file_type}; # PB_CMP.pdf

    my $request = $self->model('Request')->get_request($request_id);

    my $dir = $self->_get_destination_dir($request); # warn $dir;

    my $file = sprintf '%.02d_%.05d_%s',
        $request->year - 2000, $request->request_number, $file_type; # warn $file;

    if ( -e $dir . '/' . $file ) { # if file exists, return components:
        my @parts = ( $request->year, $self->stash->{mini_dir},
            $request->request_number, $file );
        return \@parts;
    }
    return 0;
}

#-------------------------------------------------------------------------------
sub _get_destination_dir {
    my ($self, $request) = @_; # warn Dumper $request;

    my $path_to_app_root = $self->cfg('path_to_app_root');
	my $centre = $self->cfg('settings')->{_centre}; # warn $centre;

    # 1-99 = 0, 100-199 = 1, 200-299 = 2, etc
    my $i = int $request->{request_number} / 100; # warn $i;

    my $mini_dir = sprintf '%s-%s',
        100 * $i || 1, # default to 1 if 0; 1, 100, 200, 300, etc
        100 * $i + 99; # 99, 199, 299, etc

	my @parts = ( $path_to_app_root, 'static', 'files', $centre, $request->{year},
		$mini_dir, $request->{request_number} ); # warn [ $mini_dir, $destination_dir ];

    my $destination_dir = join '/', @parts; # warn $destination_dir;

    # stash for later:
    $self->stash(
        destination_dir => $destination_dir,
        mini_dir        => $mini_dir,
    );

    return $destination_dir;
}

#-------------------------------------------------------------------------------
sub _unzip_file {
    my $self = shift;
    my $file = shift; # warn $file;

    my $u = new IO::Uncompress::Unzip $file
        or die "Cannot open $file: $UnzipError";

    my ($status, $filename);
    # get filename of content:
    for ( $status = 1; ! $u->eof(); $status = $u->nextStream() ) {
        $filename = $u->getHeaderInfo()->{Name}; # warn $filename;
        last if $filename =~ /\.csv\Z/; # HSCIC now using csv + pdf in zip
    } # warn $filename;
    die "error processing $file: $!\n" if $status < 0 ;

    # check filename ends in .csv file - returns true if so:
    $self->_check_csv($filename) || return 0;

    # split $filename:
    my ($prefix, $suffix) = split '\.', $filename; # warn $prefix; warn $suffix;

    # check it's a permitted filename - returns true if so:
    $self->_check_permitted_filename($prefix) || return 0;

    # unzip file to temp.csv (to match filename if csv uploaded):
    unzip $file => $self->_path_to_data_files . '/temp.csv',
    # HSCIC now using csv + pdf in zip so need 'Name' => $filename (already checked .csv):
    Name => $filename || die "unzip failed: $UnzipError\n";

    return $prefix; # success
}

#-------------------------------------------------------------------------------
sub _get_filename_from_url {
    my $self = shift;
    my $url  = shift;

    my ($prefix) = $url =~ m!(\w+)\.csv\Z!; # warn $filename;

    # check it's a permitted filename - returns true if so:
    $self->_check_permitted_filename($prefix) || return 0;

    return $prefix;
}

#-------------------------------------------------------------------------------
sub _check_permitted_filename {
    my ($self, $filename) = @_;

    my @allowed = ();
    { # get list of permitted .csv files:
        my @contents = io($self->_path_to_data_files)->all; # get contents of dir
        for (@contents) { # warn $_->filename;
            next unless /csv\Z/;
            my ($prefix, $suffix) = split '\.', $_->filename;
            push @allowed, $prefix;
        } # warn Dumper \@allowed;
    }

    # check filename is one of permitted files:
    unless (grep lc $filename eq $_, @allowed) {
        my $msg = $self->messages('admin')->{data_file}->{unrecognised};
        $self->flash( error => sprintf $msg, $filename );
        return 0;
    }
    return 1; # OK
}

#-------------------------------------------------------------------------------
sub _update_file {
    my ($self, $filename) = @_; # warn $filename;

    # filename (without suffix) of destination file (ensure it's lc):
    my $outfile = $self->_path_to_data_files . '/' . lc $filename . '.csv'; # ODS files usually uc

    # move existing file out of the way:
    io($outfile)->rename($outfile . '.old') || return 0;

    # rename temp file to working filename:
    io($self->_path_to_data_files . '/temp.csv')->rename($outfile) || return 0;

    return 1; # success
}

#-------------------------------------------------------------------------------
sub _check_csv {
    my ($self, $str) = @_; # warn Dumper $str;

    # check it's a csv filename:
    unless ($str && $str =~ /\.csv\Z/) {
        $self->flash( error => $self->messages('admin')->{data_file}->{not_csv} );
        return 0;
    }
    return 1;
}

#-------------------------------------------------------------------------------
sub _path_to_data_files {
    my $self = shift;

    return $self->cfg->{path_to_app_root} . '/src/data';
}

1;