package Model; use Git; use Try::Tiny; use Path::Tiny; use SQL::Library; use Digest::SHA1; use Data::Printer; use DateTime::Format::MySQL; use FindBin qw($RealBin); # warn $RealBin; use Module::Runtime qw(use_module); use Email::Sender::Simple qw(sendmail); use lib '/home/raj/perl-lib'; use Local::DB; use Local::Utils; use Moo; # required items for constructor: has app_config => ( is => 'ro', required => 1 ); # appdir, environment, etc has sql_lib => ( is => 'lazy' ); # _build_sql_lib() # has dbix => ( is => 'lazy', builder => sub { DBIx::Simple->new(shift->dbh) } ); has dbix => ( is => 'lazy' ); # _build_dbix() # BEGIN { $ENV{EMAIL_SENDER_TRANSPORT} ||= 'Test' } # to force test email delivery my $git = Git->repository(Directory => path($RealBin, '..', '.git')->realpath); our $VERSION = version(); # warn $VERSION; sub version { $git->command_oneline('rev-list', 'HEAD', '--count') } #------------------------------------------------------------------------------- sub authenticate_user { my ($self, $params) = @_; # p $params; # username is combination of OUT prefix and patient.id (use 'or' not '||') my ($userid) = $params->{userid} =~ /OUT(\d+)/ or return 0; # p $userid; my $sql = $self->sql_lib->retr('user_details'); # p $sql; # get user from users table using supplied username param, or return: my $user = $self->_query($sql, $userid) || return 0; # p $user; # don't need password authentication for dev env: unless ( $self->app_config->{environment} eq 'development' ) { # check SHA1 b64digest 'password' param matches patient_access.password: my $digest = _sha1_digest($params->{password}); # p $digest; return 0 unless $user->{password} eq $digest; } # update last_login date: my $now = 'NOW()'; # DateTime->now( time_zone => 'Europe/London' ); $self->dbix->update( 'patient_access', { last_login => \$now }, { patient_id => $user->{patient_id} }, ); return $user; } #------------------------------------------------------------------------------- sub get_outreach_data { my ($self, $patient_id) = @_; # p $patient_id; my %h; =begin # not using - report generated by HILIS4 { # results: my $sql = $self->sql_lib->retr('results'); # p $sql; my @data = $self->_query($sql, $nhs_number); # p @data; $h{results} = \@data; } =cut { # pack dispatches: my @data = do { my $sql = $self->sql_lib->retr('pack_dispatches'); # p $sql; $self->_query($sql, $patient_id); }; # p \@data; $h{packs} = \@data; # report available if request_status of *any* report is complete: for my $req (@data) { # in reverse chronological order so most recent 1st next unless $req->{request_status} eq 'complete'; # encrypt using todays date for tamper protection: my $key = Local::Utils::today->ymd; $h{print_report_token} = Local::Utils::encrypt($req->{id}, $key); last; } } return \%h; } #------------------------------------------------------------------------------- sub email_patient_demographics { my ($self, $params, $session) = @_; # p $params; p $session; my $app_config = $self->app_config; # set transport object (Mbox, Test, SMTP, TestFail, etc): =begin # for Mbox, to specify path/to/mbox: use Email::Sender::Transport::Mbox; my $transport = Email::Sender::Transport::Mbox->new({ filename => path($app_config->{appdir}, 'logs', 'mbox')->realpath, }); =cut =begin # for smtp credentials: my $cfg = $app_config->{plugins}->{Email}->{headers}; my $transport = Email::Sender::Transport::SMTP->new({ host => 'smtp.hmds.org.uk', sasl_username => 'ra.jones@hmds.org.uk', sasl_password => 'testing_invalid', # to trigger failure }); =cut my $transport = do { # TestFail = my Email::Sender::Transport::TestFail package below my $t = $ENV{MY_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; }; # p $transport; # Email::Sender::Transport object my $content = do { # first highlight any changed params: _highlight_changes($params, $session); # p $params; join "\n", map { join ': ', $_, $params->{$_} } qw(first_name last_name dob address email contact_number practice); }; my $email = Email::Simple->create( body => $content, header => [ to => $app_config->{plugins}->{Email}->{headers}->{to}, from => $session->{email}, subject => ( sprintf 'Patient demographic update [%s]', $session->{nhs_number} ), ], ); # p $email; my %h = ( msg => 'Thanks for your update, we will do something, maybe' ); try { sendmail($email, { transport => $transport } ); } catch { # set errors key, will cause route to return non-success status: $h{errors} = { sendmail => 'email failed: '.$_->message }; }; # p %h; return \%h; } #------------------------------------------------------------------------------- sub validate_password { my ($self, $params, $session) = @_; # p $params; p $session; my $digest = _sha1_digest($params->{password}); # p $digest; my %h = (); # return \%h; unless ( $session->{password} eq $digest ) { # p $session->{password}; $h{errors} = { password => "sorry, your password doesn't match!" }; } return \%h; } #------------------------------------------------------------------------------- sub gitlog { my @args = ( '--pretty=format:"%ad :: %s"', '--date=relative' ); my @log = $git->command( 'log', @args ); return \@log; }; # private subs ================================================================= sub _query { my $self = shift; my ($sql, @bind) = @_; # p $sql; p @bind; my $data = $self->dbix->query($sql, @bind)->hashes; # p $data; _autoinflate_dates($data); # return array, ref to array of hashrefs or single hashref: return wantarray ? @$data : @$data > 1 ? $data # AoH : $data->[0]; # href } #------------------------------------------------------------------------------- sub _highlight_changes { # modifies $params hashref - no return expected my ($params, $session) = @_; my $highlight = sub { '!!! ' . $_[0] . ' !!!' }; $params->{$_} = &$highlight($params->{$_}) for grep lc $params->{$_} ne lc $session->{$_}, qw(first_name last_name email contact_number); $params->{dob} = &$highlight($params->{dob}) if $params->{dob} ne $session->{dob}->strftime('%d %b %Y'); # address & practice are composited on form: $params->{address} = &$highlight($params->{address}) if $params->{address} ne join ', ', @{$session}{qw/address post_code/}; $params->{practice} = &$highlight($params->{practice}) if $params->{practice} ne join ', ', @{$session}{qw/gp practice/}; return 0; } #------------------------------------------------------------------------------- # if it looks like a MySQL date or date + time, inflate to DateTime object: sub _autoinflate_dates { my $data = shift; my $re = qr!\d{4}-\d{2}-\d{2}(\s\d{2}:\d{2}:\d{2})?!; my $to_datetime = sub { my $val = shift // return; # p $val; # must use // or lose $val of zero if ( my ($date) = $val =~ m!\A($re)\Z! ) { # p $date; $val = length $date > 10 # ie date + time ? DateTime::Format::MySQL->parse_datetime($date) : DateTime::Format::MySQL->parse_date($date); } return $val; }; for my $ref(@$data) { $ref->{$_} = &$to_datetime($ref->{$_}) for keys %$ref; } } #------------------------------------------------------------------------------- sub _sha1_digest { my $str = shift; # p $str; my $sha1 = Digest::SHA1->new; $sha1->add($str); return $sha1->b64digest; } #------------------------------------------------------------------------------- sub _build_sql_lib { my $lib = shift->app_config->{appdir} . '/src/queries.sql'; SQL::Library->new({ lib => $lib }); }; #------------------------------------------------------------------------------- sub _build_dbix { Local::DB->dbix({ dbname => shift->app_config->{db_name} }) } =begin sub _build_dbix { # warn 'building dbix object'; my $dsn = 'dbi:mysql:database=hilis4;mysql_read_default_file=~/.local/mysql.cnf'; DBIx::Simple->connect($dsn); } =cut { package Email::Sender::Transport::TestFail; use Data::Printer; use Moo; extends 'Email::Sender::Transport::Test'; sub delivery_failure { my ($self, $email) = @_; # p $email; return Email::Sender::Failure->new('test delivery failure'); } no Moo; 1; } 1;