• 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) = @_;	
	
	# set path to image_server folder
	my $path_to_app_root = $self->cfg('path_to_app_root');
	
    # 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
	my $filename = basename($fh); # warn $filename;
	
    my $file = join '/', $destination_dir, $filename;
	
	# 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 = shift;	
	
    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);
        }
    }

	# 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;
	
	io($file)->unlink;
}

#-------------------------------------------------------------------------------
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');
    
    # 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 $destination_dir = $path_to_app_root . '/static/image_server/'
    . $request->{year} . '/'
    . $mini_dir . '/'
    . $request->{request_number}; # warn [ $mini_dir, $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;
    
    my $u = new IO::Uncompress::Unzip $file
        or die "Cannot open $file: $UnzipError";

    my ($status, $content);
        
    # get filename of content:
    for ( $status = 1; ! $u->eof(); $status = $u->nextStream() ) {
        $content = $u->getHeaderInfo()->{Name};
    }
    die "error processing $file: $!\n" if $status < 0 ;

    # check it's a csv file - returns true if so:
    $self->_check_csv($content) || return 0;
    
    # split $content:
    my ($prefix, $suffix) = split '\.', $content;
    
    # 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'
    || 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, $content) = @_;
    
    # check it's a csv file:
    unless ($content =~ /\.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;