• 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_snomed_code {
	my $self = shift;

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

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

		# C, 2 numbers, dot, number:
		return ( $val =~ /\A(C\d{2}\.\d)\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 eg [dob_day, etc]
		# warn Dumper $param_names;

	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);

=begin # fails to detect invalid yr = 19.7 !!
        my $result = FormValidator::Simple->check(
            $data => [
                { datetime => $param_names } => [ 'DATETIME' ]
            ]
        ); # warn Dumper $result->has_error;
		return $result->has_error ? 0 : 1;
=cut
		my ($d) = map $data->{$_}, grep $_ =~   /day\Z/, @$param_names; # warn $d;
		my ($m) = map $data->{$_}, grep $_ =~ /month\Z/, @$param_names; # warn $m;
		my ($y) = map $data->{$_}, grep $_ =~  /year\Z/, @$param_names; # warn $y;
		eval { DateTime->new(year => $y, month => $m, day => $d) }; # warn $@ if $@;
		return $@ ? 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_vial_Id_length {
	my $self = shift;

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

		my $val = $dfv->get_current_constraint_value(); # warn $val; warn length($val);
        # multiples of 10 chars:
        # return ( length($val) % 10 ) ? 0 : 1; # fails if modulus result evals 'true'
		return ( length($val) == 10 ); # only allowing singlicates now using partnums
	}
}

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

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

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

        my $vials = LIMS::Local::Utils::extract_storage_vial_ids($val); # arrayref
        my %seen; # in case same vial re-scanned

        for my $id(@$vials) { # warn $id;
            return 0 if $seen{$id}++; # ie if vial re-scanned
            # check vialID unique (function returns false if ID already exists):
            $self->models->{has_unique_storage_vialId}->($id) || return 0;
        }
        return 1;
	}
}

#-------------------------------------------------------------------------------
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;
	};
}

#-------------------------------------------------------------------------------
# check service entry in application email matches logged in user centre:
sub check_lims_service {
    my ($self, $service) = @_; # warn $service;

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

		my $val = $dfv->get_current_constraint_value(); # warn $val;
		return ( $val eq $service );
	}
}

#-------------------------------------------------------------------------------
# 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;