• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Validate::Roles::ConstraintMethods;

# contains constraint_method helper methods for LIMS::Validate

use Moose::Role;
use namespace::clean -except => 'meta';

use Data::Dumper;
use LIMS::Local::Utils;
use FormValidator::Simple qw(+LIMS::Validate::DatePlugin);
use Data::FormValidator::Constraints
	qw(:regexp_common FV_max_length FV_length_between valid_email);
use Data::FormValidator::Constraints::DateTime qw(:all); # using: ymd_before_today()
use Data::FormValidator::Constraints::MethodsFactory qw(:bool); # FV_and

#-------------------------------------------------------------------------------
sub check_nhsno_is_valid {
	my $self = shift; # warn 'here'; warn Dumper $self;
	
	return sub {
		my $dfv = shift; # warn 'here'; warn Dumper $dfv;
		my $nhs_number = shift || return 0; # warn 'NHSNo:'.$nhs_number;

		$dfv->name_this('is_valid');
		
		# check_nhsno() return true if valid:
		my $is_valid = LIMS::Local::Utils::check_nhsno( $nhs_number ); # warn $is_valid;
		return $is_valid;
	}
}

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

	return sub {
		my $dfv = shift; # warn 'here'; warn Dumper $dfv;
		my $nhs_number = shift || return 0; # warn 'NHSNo:'.$nhs_number;

		$dfv->name_this('is_unique');

		my $validation_model = $self->models->{validate_nhs_number_unique};

		my $not_unique = $validation_model->($nhs_number);

		return $not_unique ? 0 : 1;
	}
}

#-------------------------------------------------------------------------------
sub check_email_is_valid {
	my $self = shift;
	
	return sub {
		my ($dfv, $email) = @_; # warn $email;
		return valid_email($email); # Data::FormValidator::Constraints method
	}	
}

#-------------------------------------------------------------------------------
sub check_emails_match {
	return sub {
		my $dfv = shift; # DEBUG($dfv);
		$dfv->name_this('email_mismatch'); 

		my $data = $dfv->get_filtered_data; # DEBUG($data);    	
		return ($data->{email} eq $data->{email2}); # returns truth
	};
}

#-------------------------------------------------------------------------------
sub check_post_code_is_valid {
	my $self = shift;
	
	return sub {
		my ($dfv, $zip) = @_; # warn $zip;
		return LIMS::Local::Utils::format_postcode($zip);
	}	
}

#-------------------------------------------------------------------------------
=begin # moved to C::Request::_check_secure_recipient()
sub check_secure_email_domain {
	my $self = shift;

	my $settings = $self->settings;
	my @valid_domains = split /\,\s?|\s+/, $settings->{valid_recipient_domains};

	return sub {
		my ($dfv, $email) = @_; # warn $email;
		return grep $email =~ /$_\Z/, @valid_domains;
	}	
}
=cut

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

	return sub {
		my $dfv = shift; # warn 'here';		
		$dfv->name_this('no_spaces');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;
		
		my ($is_valid) = $val =~ /^[a-zA-Z0-9_]+$/; # warn $is_valid;

		return $is_valid;
	}	
}

#-------------------------------------------------------------------------------
sub check_username { # allows alphanumeric with optional hyphen (Foo-Bar)
	my $self = shift; 

	return sub {
		my $dfv = shift; # warn 'here';		
		$dfv->name_this('username');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;
		# requires first letter, then apostrophe, hyphen or more letters:
		my $re = qr{[a-z][-'\.a-z]+};
		
		my ($is_valid) = $val =~ /\A($re)\Z/; # warn Dumper $is_valid;

		return $is_valid;
	}	
}

#-------------------------------------------------------------------------------
# used by new_request() & Ajax::_validate_params()
sub get_request_number_constraints {
	my $self = shift;

	my $is_unique = sub {
		my $dfv = shift; # warn 'here';		
		$dfv->name_this('is_unique');

		my $val = $dfv->get_current_constraint_value(); # warn $val;
		my $uniqueness = $self->check_request_number($val);
		return $uniqueness;
	};
	
	my $max_request_number_length = $self->settings->{max_request_number_length};

	return [ # TODO: join_these() doesn't work here
		$is_unique, # check it's unique
		FV_num_int, # must be integer; Regexp::Common, s/RE/FV/
		$self->check_param_length([ 1, $max_request_number_length ]), # don't expect >99_999/yr
#		FV_clamp(1, 1, 5), # MethodsFactory method - no configurable msgs output ?
	];
}

#-------------------------------------------------------------------------------
# used by new_request() & Ajax::_validate_params()
sub get_request_number_messages { 
	my $self = shift;

	return { # messages need to be set to constraint_names, not field_names:
		constraints => {
			is_unique      => $self->messages->{not_unique},
			FV_num_int     => $self->messages->{need_integer},
            # FV_length_between in check_param_length() doesn't work with D::F 4.71 ??
			length_between => $self->messages->{too_long},
            #now using 'name_this' in check_param_length() instead:
			max_length     => $self->messages->{too_long}, 
		},
	};
}

#-------------------------------------------------------------------------------
# uses model to get param type (int or decimal) from defaults_and_ranges table:
sub get_hmrn_param_constraints {
	my ($self, $fields) = @_; # warn Dumper $fields;
    
    # get all hmrn param defaults_and_ranges data:
    my $data = $self->models->{hmrn_param_constraints}->(); # warn Dumper $data;

    my %constraint_method = (); # hash for constraint methods
    
    PARAM:
    for my $param(@$fields) { # get data for this param, or skip to next:
        if ( my $d = $data->{$param} ) { # warn Dumper $d;
            my $field_type = $d->{field_type}; # int or decimal
            if ($field_type eq 'int') {
                $constraint_method{$param} = FV_num_real();
            }
            elsif ($field_type eq 'decimal') {
                $constraint_method{$param} = FV_num_decimal();
            }
        }
    } # warn Dumper \%constraint_method;
    return \%constraint_method;
}

#-------------------------------------------------------------------------------
# can have non-unique test_names, but not with same lab_section_id:
=begin ? not in use
sub check_lab_test_is_valid {
	my $self = shift;
	
	return sub {
		my $dfv = shift;		
		$dfv->name_this('is_unique');

		my $data = $dfv->get_filtered_data; # warn Dumper $data;

		my $validation_model = $self->models->{validate_lab_test};
		
		my $is_valid = $validation_model->($data);
		return $is_valid;
	}
}
=cut

#-------------------------------------------------------------------------------
sub get_new_request_specimen_constraints { # needs to check block_ref as well:
	my $self = shift;

    my $constraint = FV_and(
        $self->check_external_reference(),
        $self->get_specimen_constraints(),
    );
    return $constraint;
}

#-------------------------------------------------------------------------------
# used by new_request() & Ajax::_validate_params()
sub get_specimen_constraints {
	my $self = shift; 

	return sub {
		my $dfv = shift; # warn 'here';		
		$dfv->name_this('check_specimen');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;
		
		my $is_valid = $self->check_specimen($val); # warn $is_valid;

		return $is_valid;
	}
}

#-------------------------------------------------------------------------------
# checks entry(s) in specimen field exists in specimens table:
# (not a DFV method so doesn't receive dfv object)
sub check_specimen { # warn Dumper @_;
	my $self = shift;

	my $str = shift || return 0; # warn 'specimens:'.$str;

    my $models = $self->models;
    
    # extract specimens from $str:
    my $specimens = LIMS::Local::Utils::get_specimens($str); # warn Dumper $specimens;

    my $max_length # get max length of sample_code col from specimens table meta data:
        = $models->{get_meta}->('Specimen')->column('sample_code')->length;
    
	my $validator = sub { $models->{validate_specimen}->(@_) }; 
    
    foreach my $specimen (@$specimens) { # warn Dumper $specimen;
        return 0 if length $specimen > $max_length; # as next line is fatal if > max length
        my $valid = &$validator($specimen);	# warn Dumper [$specimen, $valid];
        return 0 if ! $valid;
    }
	# OK, specimen(s) valid:
	return 1;
}

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

	return sub {
		my $dfv = shift; #  warn Dumper $dfv;		
		$dfv->name_this('referrer_code');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;

		# C, D, E or CS followed by 5-7 numbers:
		return ($val =~ /\A([CDE]|CS)\d{5,7}\Z/) ? 1 : 0;
	}
}

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

	my $request_number = shift || return 0; # warn 'request_number:'.$request_number;

	my $validation_model = $self->models->{validate_request_number};

	my $not_unique = $validation_model->($request_number);

    return $not_unique ? 0 : 1;
}

#-------------------------------------------------------------------------------
sub get_date_constraints {
	my $self   = shift;
    my $prefix = shift; # optional - to support forms with multiple dates eg dob, request date, etc
	
	my $constraint = FV_and(
		$self->check_four_digit_year($prefix),
		$self->check_date_is_valid($prefix),
		$self->check_date_not_future($prefix),
	);# warn Dumper $constraint;
	
	return $constraint;
}

#-------------------------------------------------------------------------------
sub get_change_password_profile {
	my $self = shift;
	    
	return [ # FormValidator::Simple method
        new_password         => [ 'NOT_BLANK', ['LENGTH', 5, 255 ] ],
        old_password         => [ 'NOT_BLANK', ['LENGTH', 4, 255 ] ], # HILIS3 min.
        new_password_confirm => [ 'NOT_BLANK', ['LENGTH', 5, 255 ] ],
        { pwds => ['new_password', 'new_password_confirm'] } => [ 'DUPLICATION' ],
    ];
}

#-------------------------------------------------------------------------------
# uses FV_and() to return constraint_method, which executes list in order &
# exits on 1st failure, instead of executing all and potentially generating errs
sub join_these {
	my $self = shift;

	return FV_and(@_);
}

#-------------------------------------------------------------------------------
sub check_four_digit_year {
	my $self   = shift;
	my $prefix = shift; # optional, used if form has >1 date type (eg request date, dob)
    
    my $year_field_name = $prefix
        ? $prefix.'_year' # eg request_year, dob_year
        : 'year';
        
	return sub {
		my $dfv = shift; # warn Dumper $dfv;		
		$dfv->name_this('yyyy_format');
		
		my $data = $dfv->get_filtered_data; # warn Dumper $data;		
		return ( length $data->{$year_field_name} == 4 );
	}
}

#-------------------------------------------------------------------------------
sub check_numeric {
	my $self = shift;
	
	return sub {
		my $dfv = shift; #  warn Dumper $dfv;		
		$dfv->name_this('numeric_format');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;
		
		# digits only:
		my ($is_valid) = $val =~ /^[0-9]+$/; # warn $is_valid;
		
		return $is_valid; 
	}
}

#-------------------------------------------------------------------------------
# override MethodsFactory method until can find out how to target msgs at it
sub _FV_clamp {
	my $self = shift;
    my ($result, $low, $high) = @_;
    return sub {
        my $dfv = shift;
		$dfv->name_this('FV_clamp');
        my $val = $dfv->get_current_constraint_value();
        return (($val < $low) or ($val > $high)) ? !$result : $result;
    }
}

#-------------------------------------------------------------------------------
# or could use 'day => ymd_before_today( qw/year month day/ )'
sub check_date_not_future {
	my $self   = shift;
	my $prefix = shift; # optional, used if form has >1 date type (eg request date, dob)
    
    my $param_names = $self->_get_date_param_names($prefix); #arrayref
    
	return sub {
		my $dfv = shift; #  warn Dumper $dfv;
		$dfv->name_this('future_date'); 

		my $data = $dfv->get_filtered_data; # warn Dumper $data;
		
		# returns error if date not less than DateTime->now:
		my @cmp = (	'DATE_LESS_THAN', DateTime->now );
		
		my $result = FormValidator::Simple->check(
            $data => [
                { grouped => $param_names } => [ \@cmp ],
            ]
        ); # warn Dumper $result->has_error;
		
		return $result->has_error ? 0 : 1;
	}
}
	
#-------------------------------------------------------------------------------
# if hidden flag '_diagnosis_id' passed, also need either 'option_id' or
# 'final_diagnosis' param:
sub check_report_params { 
	my $self = shift;
	
	return sub {
		my $dfv = shift; # warn Dumper $dfv;
	
		$dfv->name_this('diagnosis_resubmission');
		my $data = $dfv->get_filtered_data; # warn Dumper $data;
		
		my $original_diagnosis_id = $dfv->get_current_constraint_value();
		
        return ( $data->{option_id} # need either no change OR reason for change:
            || $original_diagnosis_id == $data->{diagnosis_id} );
        
=begin  # changed this to ALWAYS require reason for change diagnosis
		# eg authorisation, without change of diagnosis_id:
		return 1 if $original_diagnosis_id == $data->{diagnosis_id};
		
		# require either 'final_diagnosis' or 'option_id' params:
		return grep $data->{$_}, qw(final_diagnosis option_id);
=cut
	}
}

#-------------------------------------------------------------------------------
# external_reference required if sample-type is histological
sub check_external_reference {
	my $self = shift;
    return sub {        
		my $dfv = shift; # warn Dumper $dfv;
	
		$dfv->name_this('block_reference');
		my $data = $dfv->get_filtered_data; # warn Dumper $data;
        
        my $specimens = LIMS::Local::Utils::get_specimens($data->{specimen}); # warn Dumper $specimens;
        return 1 unless grep $_ =~ /[BS]L\Z/i, @$specimens;
        return ($data->{external_reference}); # returns true if exists
    };
}

#-------------------------------------------------------------------------------
# # check end_date NOT before start_date - returns true (1) UNLESS $second_date
# BEFORE $first_date:
sub check_date_order {
	my $self = shift; 

    my $cfg = $self->settings;
    
	return sub {
		my $dfv = shift; # warn Dumper $dfv;
		$dfv->name_this('date_order'); 

		my $data = $dfv->get_filtered_data; # warn Dumper $data;	
        
		# LIMS::Local::Utils::check_chronological_order() requires DateTime objects:
		my $start_date
			= LIMS::Local::Utils::to_datetime_using_datecalc($data->{start_date});
		my $end_date
			= LIMS::Local::Utils::to_datetime_using_datecalc($data->{end_date});
		
        # exempt default unknown date from date order check:
        return 1 if $start_date && $end_date # don't try ymd() method on undef val!!
            && grep $_->ymd eq $cfg->{default_unknown_date},
                ($start_date, $end_date);
        
		my $val # returns '-1' if dates in chronological order (0 if equal, otherwise 1):
			= LIMS::Local::Utils::check_chronological_order($end_date, $start_date);
			# warn Dumper $val;
		return $val == -1 ? 0 : 1; # return false if $expr eq -1 ie in date order
	}
}

#-------------------------------------------------------------------------------
sub check_date_is_valid {
	my $self   = shift; 
	my $prefix = shift; # optional, used if form has >1 date type (eg request date, dob)

    my $param_names = $self->_get_date_param_names($prefix); #arrayref

	return sub {
		my $dfv = shift; #  warn Dumper $dfv;
		my $data = $dfv->get_filtered_data; # warn Dumper $data;		
        
        my $name = ( $data->{hour} || $data->{minute} )
            ? 'valid_datetime' : 'valid_date';
		$dfv->name_this($name); 

        my $result = FormValidator::Simple->check(
            $data => [
                { datetime => $param_names } => [ 'DATETIME' ]
            ]
        ); # warn Dumper $result->has_error;
		
		return $result->has_error ? 0 : 1;
	};
}

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

	return sub {
		my $dfv = shift; # warn Dumper $dfv;
		$dfv->name_this('valid_date'); 

		my $val = $dfv->get_current_constraint_value(); # warn $val;

        my $result = LIMS::Local::Utils::check_date($val); 
		return $result;
	};
}

#-------------------------------------------------------------------------------
sub check_param_length {
	my $self = shift;
	my $arg  = shift; # warn Dumper $arg;
	
	return sub {
		my $dfv = shift; #  warn Dumper $dfv;		
		$dfv->name_this('max_length');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;
		
		my $result = ref $arg eq 'ARRAY'
            ? ( length($val) >= $arg->[0] && length($val) <= $arg->[-1] )
            : length($val) <= $arg; # warn Dumper $result;
        return $result;
	};
    
=begin # doesn't work after Data::FormValidator updated from 4.63 to 4.71
    # if $arg is arrayref, assume length_between, otherwise max_length:
#	return
#		ref $arg eq 'ARRAY' ?
#			FV_length_between(@$arg) :
#				FV_max_length($arg);
=cut
}

#-------------------------------------------------------------------------------
# checks param is either unique, or belongs to submitted record id:
sub check_param_ownership {
	my $self = shift;
	my $tbl_info = shift; # arryref of 'col_name' & 'class'

	return sub {
		my $dfv = shift; # warn Dumper $dfv;
		my $data = $dfv->get_filtered_data; # warn Dumper $data;

		$dfv->name_this('ownership');

		my %args = (
			col   => $tbl_info->[0], # can be arrayref of col_names
			class => $tbl_info->[1],
			data  => $data,
		); # warn Dumper \%args;

		# returns 'true' if param unique, or already belongs to record id:
		my $unique_or_belongs_to_record
			= $self->models->{validate_param_ownership}->(\%args);

		# so just return value of expression:
		return $unique_or_belongs_to_record;	
	};		
}

#-------------------------------------------------------------------------------
# allows for form to submit several date params, eg request_year, dob_year, etc
sub _get_date_param_names {
    my $self   = shift;
    my $prefix = shift; # optional, used if form has >1 date type (eg request date, dob)
    
    my @param_names = qw(year month day hour minute);
    
    if ($prefix) { # eg validating request_year, request_day, etc
        map { $_ = $prefix . '_' . $_ } @param_names; # eg year => dob_year
    } # warn Dumper \@param_names;
    
    return \@param_names;
}

1;