package Reporter::Model;
use Reporter::Validator; # Data::FormValidator class
use Reporter::Class; # provides Moo, Clone, Modern::Perl, Local::MooX::Types & Data::Printer::p
use Reporter::DB;
has dbname => ( is => 'ro', isa => String, required => 1 ); # hilis4, test, etc
has config => ( is => 'ro', isa => HashReference, required => 1 ); # app config
has cache => ( is => 'rw', isa => HashReference, default => sub { {} } );
has db => (
is => 'lazy',
handles => [ 'check_db_connection' ], # to check db handle still connected
);
sub _build_db {
my $self = shift;
Reporter::DB->new( dbname => $self->dbname, config => $self->config );
}
has validator => ( # Data::FormValidator
is => 'lazy',
builder => sub { Reporter::Validator->new },
);
use IO::All;
use Digest::SHA1;
use File::Temp qw(tempfile);
use DateTime::Format::MySQL;
use Local::Paginator qw(paginate);
use Email::Sender::Simple qw(sendmail);
# BEGIN { $ENV{EMAIL_SENDER_TRANSPORT} = 'Test' } # to force test email delivery
# or to 'TestFail' to cause it to fail
# use Lingua::EN::Numbers qw(num2en_ordinal);
#-------------------------------------------------------------------------------
sub validate_user_credentials {
my ($self, $params) = @_; # p $params;
my $userid = $params->{userid}; # username or email addr
my $passwd = $params->{password};
if ( my $user = $self->db->get_user_data($userid) ) { # p $user;
return $user if $self->config->{environment} eq 'development'; # don't need pwd
my $digest = _sha1_digest($passwd); # p $digest;
return $user if $user->{password} eq $digest;
}
# either no user retrieved by username or passwd, or passwd incorrect:
return 0;
}
#-------------------------------------------------------------------------------
sub register_user {
my ($self, $params) = @_; # p $params;
my $result = do { # clone $params, replace password value with sha1_digest:
my $ref = clone $params;
$ref->{password} = _sha1_digest($params->{password}); # p $ref;
$self->db->register_user($ref);
};
return $result;
}
#-------------------------------------------------------------------------------
sub email_registration {
my ($self, $params) = @_; # p $data;
my $app_config = $self->config;
my $transport = do {
# TestFail = my Email::Sender::Transport::TestFail package below
my $t = $ENV{EMAIL_SENDER_TRANSPORT} # command-line ENV has priority
|| $params->{email} =~ /fail/ # then web-form 'email' param =~ /fail/
? 'TestFail' # then .yml setting, finally default smtp:
: $app_config->{email_sender_transport} || 'SMTP';
my $transport_module = 'Email::Sender::Transport::'.$t;
use_module($transport_module)->new; # p $transport_module;
}; # ddp $transport; # Email::Sender::Transport object
my $content = _format_message($params);
my $email = Email::Simple->create(
body => $content,
header => [
to => $params->{email},
cc => $app_config->{admin_email},
from => $app_config->{email_from},
'reply-to' => $app_config->{admin_email},
subject => ( 'HMDS draft reporter registration' ),
],
); # ddp $email->as_string; ddp $email->header_pairs;
my %h = ();
try {
sendmail($email, { transport => $transport } );
}
catch {
$h{error} = 'email failed: '.$_->message;
}
finally { # attach message to tt if test script:
$h{email_as_string} = $email->as_string
if $ENV{EMAIL_SENDER_TRANSPORT} =~ /Test/;
}; # p %h;
return \%h;
}
sub _format_message {
my $params = shift;
return sprintf qq!
Hello %s %s,
Your HMDS draft reporter registration details:
username: %s
password: %s
Address: <http://hmds/reporter>!,
ucfirst($params->{first_name}),
ucfirst($params->{last_name}),
@{$params}{qw/email password/};
}
#-------------------------------------------------------------------------------
sub load_request {
my ($self, $args) = @_; # p $args;
my ($lab_number, $user_id) = map $args->{$_}, qw(lab_number user_id);
# split lab_number into request_number & yr:
my ($request_number, $yr) = $lab_number =~ m!(\d+)/(\d{2})!;
# request data:
my $request = $self->db->get_request_data($request_number, $yr); # p $request;
my $request_id = $request->{id} || return 0; # in case request not found
{ # section result summaries:
my $data = $self->db->get_result_summaries($request_id); # p $data;
$request->{result_summaries} = $data;
}
{ # lab test results:
my $data = $self->db->get_lab_test_results($request_id); # p $data;
$request->{test_results} = $data;
}
{ # previous cases:
my $nhs_number = $request->{nhs_number}; # will return empty if undef:
my $previous = $self->db->get_previous_requests($request_id, $nhs_number);
if ($previous) { # p $previous;
$_->{auth_date} = $self->to_datetime($_->{auth_date}) for @$previous;
$request->{previous_requests} = $previous;
}
}
{ # previous draft report by same user:
my $data = $self->db->get_report_data($request_id, $user_id); # p $data;
$data->{$_} = $self->to_datetime($data->{$_})
for qw(created_at updated_at);
$request->{report} = $data;
}
# dates to datetime:
$request->{$_} = $self->to_datetime($request->{$_}) for qw(registered dob);
# store for later use:
$self->cache( { request_data => $request } );
return $request;
}
#-------------------------------------------------------------------------------
sub get_validation_profile {
my ($self, $profile_name) = @_; # p $profile_name;
# clone DFV profile otherwise changes affect original profiles hashref:
my $profile = clone $self->validator->profiles->{$profile_name}; # p $profile;
if ( $profile_name eq 'report' ) { # possibly add new required fields:
my $required_fields = $profile->{required}; # p $required_fields; # arrayref
my $request_data = $self->cache->{request_data}; # p $request_data;
my $specimen = $request_data->{specimen};
my %re = (
fixed_or_trephine => qr{BMAT|[DGLRXT]([BS][LP]|F|U)},
histology_type => qr{[DGLRX]([BS]L|F|U)},
);
push @$required_fields, 'biopsy_site'
if $specimen =~ /$re{histology_type}/;
push @$required_fields, 'gross_description'
if $specimen =~ /$re{fixed_or_trephine}/;
} # p $profile;
return $profile;
}
#-------------------------------------------------------------------------------
sub get_reports_for_user {
my ($self, $args) = @_; # p $args;
my $user_id = $args->{user_id};
my $config = $self->config->{paginator}; # p $config;
my $page = $args->{page};
my $uri = $args->{uri};
my $limit = $config->{page_item_count}; # p $limit;
my $total = $self->db->get_report_counts_for_user($user_id); # p $total;
# get list of reported requests for this user:
my $data = do {
my %args = (
limit => $limit,
offset => $limit * ($page - 1),
);
$self->db->get_reports_for_user($user_id, \%args);
}; # p $data;
# registration date to datetime:
$_->{created_at} = $self->to_datetime($_->{created_at}) for @$data;
my %h = ( reports => $data );
if ( $total > $limit ) { # need pagination:
my %args = (
entries_per_page => $limit,
total_entries => $total,
current_page => $page,
sibs => $config->{siblings},
uri => $uri . '?page=',
); # p %args;
my $paginator = paginate(\%args); # adds formatted html to %args
$h{paginator} = $paginator;
}
return \%h;
}
#-------------------------------------------------------------------------------
sub user_reports_list {
my ($self, $user_id) = @_; # p $user_id;
my $data = $self->db->get_reports_for_user($user_id); # p $data;
$_->{created_at} = $self->to_datetime($_->{created_at}) for @$data;
my %specimen; # specimen type => count map:
$specimen{ $_->{specimen} }++ for @$data; # p %specimen;
# sort by frequency in descending order:
my @specimens = map {
{ id => $_, n => $specimen{$_} }; # frequency then alphabetically:
} sort { $specimen{$b} <=> $specimen{$a} || $a cmp $b } keys %specimen;
my %h = (
reports => $data,
specimen => \@specimens,
);
return \%h;
}
#-------------------------------------------------------------------------------
sub render_pdf {
my ($self, $content) = @_; # p $content;
# create temp file for input to wkhtmltopdf (default is to UNLINK):
my $tmp_file = File::Temp->new(SUFFIX => '.html', UNLINK => 1); # p $tmp_file;
io($tmp_file->filename)->print($content); # save file to disk
my @args = (
'--header-spacing 5',
'--footer-spacing 5',
'--header-font-size 9',
'--footer-font-size 9',
qq!--header-right 'Printed on: [date]'!,
qq!--footer-center 'Page [page] of [toPage]'!,
);
my $pdf = `/usr/local/bin/wkhtmltopdf -q @args $tmp_file -`;
return $pdf;
}
#-------------------------------------------------------------------------------
sub save_report {
my ($self, $data) = @_; # p $data;
my $result = $self->db->save_report($data); # p $result;
{ # construct msg for tt (displayed if no error from insert/update):
my $action = $result->{action};
my %msgs = (
create_record => 'new record created successfully',
update_record => 'record updated successfully',
); # p $msgs{$action};
$result->{message} = $msgs{$action} || 'unknown action';
}
return $result; # hashref of keys success, message & optional error
}
#-------------------------------------------------------------------------------
sub get_diagnoses {
my ($self, $str) = @_; # p $str;
return 0 unless length $str >= 3; # causes db error if undef
my $data = $self->db->get_diagnoses($str); # p $data;
return $data;
}
#-------------------------------------------------------------------------------
sub get_lab_number { shift->db->get_lab_number(@_) }
#-------------------------------------------------------------------------------
sub num2ordinal { num2en_ordinal($_[1]) }
#-------------------------------------------------------------------------------
sub to_datetime {
my $self = shift;
my $date = shift || return;
return $date =~ /\d{2}:\d{2}:\d{2}$/ # time
? DateTime::Format::MySQL->parse_datetime($date)
: DateTime::Format::MySQL->parse_date($date);
}
#-------------------------------------------------------------------------------
sub _sha1_digest {
my $str = shift; # warn $str;
my $sha1 = Digest::SHA1->new;
$sha1->add($str);
return $sha1->b64digest;
}
{
package Email::Sender::Transport::TestFail;
use Data::Printer;
use Moo;
extends 'Email::Sender::Transport::Test';
sub delivery_failure {
my ($self, $email) = @_; # ddp $email;
return Email::Sender::Failure->new('test delivery failure');
}
no Moo;
1;
}
1;
