package LIMS::Local::ScriptHelpers; #------------------------------------------------------------------------------- # provides dbix, sql_lib, lims_config & template objects to stand-alone scripts #------------------------------------------------------------------------------- use Moose; with ( 'LIMS::Model::Roles::Query', # sql_lib() 'LIMS::Local::Role::DiagnosisAlert', 'LIMS::Local::Role::DiagnosisConfirm', ); has secure_contacts => ( is => 'ro', isa => 'HashRef', lazy_build => 1 ); has user_emails => ( is => 'ro', isa => 'HashRef', lazy_build => 1 ); has test_only => ( is => 'rw', isa => 'Str' ); # skips email recipients execept raj has use_path => ( is => 'rw', isa => 'Str' ); # allows scripts to override default path_to_app_root has template => ( is => 'ro', isa => 'Template', lazy_build => 1 ); has config => ( is => 'ro', isa => 'HashRef', lazy_build => 1 ); # settings.txt has dbix => ( is => 'ro', isa => 'DBIx::Simple', lazy_build => 1 ); __PACKAGE__->meta->make_immutable; use IO::All; use Net::FTP; use Template; use Config::Auto; use Data::Dumper; use Net::SCP::Expect; use LIMS::Local::Utils; use LIMS::Model::Email; use LIMS::Local::Config; use LIMS::Local::DBIxSimple; # patched to allow omniholders with individual placeholders use DateTime::Format::Strptime; # for Role::DiagnosisAlert: sub get_settings { return shift->config } # content of settings.txt file sub get_sql_lib { return shift->sql_lib } sub get_dbix { return shift->dbix } BEGIN { use FindBin qw($Bin); # warn $Bin; # use lib "$Bin/../../../lib"; # use lib "$Bin/../../../config"; # warn Dumper \@INC; } 1; sub process_template { my ($self, $tmpl, $data) = @_; my $tt = $self->template; my $output; $tt->process($tmpl, $data, \$output); # warn Dumper $filled_tmpl; return $output; } sub ftp_file { my ($self, $args) = @_; # warn Dumper $args; return; # can pass timeout as arg, default is 60 seconds if no value specified; # Timeout => $args->{timeout} my $ftp = Net::FTP->new( $args->{server_addr}, Debug => 0 ) || return "Cannot connect to $args->{server_addr}: $@"; if ($args->{username} && $args->{password}) { $ftp->login(@{$args}{qw/username password/}) || return 'Cannot login - ' . $ftp->message; } $ftp->binary() unless $args->{ascii_mode}; $ftp->passive(1) if $args->{passive_mode}; $ftp->cwd($args->{cwd}) if $args->{cwd}; $ftp->put($args->{local_filename}, $args->{remote_filename}) # need to return NOW, or err message() will be replaced by outcome of quit(): || return 'FTP put() error - ' . $ftp->message; $ftp->quit; return 0; # don't return message() here - will be result of quit() eg 'goodbye' } sub scp_file { my ($self, $args) = @_; # warn Dumper $args; my %auth = ( host => $args->{server_addr}, user => $args->{username}, password => $args->{password}, # don't need this if using ssh keys ); my $dest = '/'; # root dir for login my $src = $args->{local_filename}; my $scp = Net::SCP::Expect->new(%auth); # uses hash args # my $scp = Net::SCP->new(\%auth); # if using ssh keys; uses hashref args ?? $scp->scp($src, $dest); return $scp->{errstr} if $scp->{errstr}; } sub get_server_user_details { my $self = shift; my $server_username = $self->config->{server_username}; my $sql = 'select * from users where username = ?'; my $user = $self->dbix->query($sql, $server_username)->hash; # warn Dumper $user; return $user; } sub get_yaml_file { my ($self, $file) = @_; my $cfg = $self->config; # warn Dumper $cfg; my %args = ( app_root => $self->path_to_app_root, yaml_dir => $cfg->{yaml_dir}, filename => $file, ); my $yaml = LIMS::Local::Utils::get_yaml(\%args); return $yaml; } sub send_mail { my ($self, $mail, $recipients) = @_; my $JUST_TESTING = $self->test_only(); # warn $JUST_TESTING; RECIPIENT: foreach my $recipient (@$recipients) { my $addr = ( $recipient =~ /\@nhs.net/ ) ? $recipient # use directly if already email address format : $self->recipient_address($recipient); unless ($addr) { # in case it doesn't exist my $filename = $self->script_filename; warn "$filename: can't find address for $recipient"; next RECIPIENT; } next RECIPIENT if ( $JUST_TESTING && $addr !~ /ra\.jones/ ); $mail->{recipient} = $addr; # warn Dumper $mail; # next; my $ok = $self->send_message($mail); # returns 1 on success, 0 on failure return 0 unless $ok; # most callers don't care about return } return 1; # all recipients OK } sub send_message { # returns 1 on success, 0 on failure my ($self, $mail) = @_; my $JUST_TESTING = $self->test_only(); # warn $JUST_TESTING; return 0 if ( $JUST_TESTING && $mail->{recipient} !~ /ra\.jones/ ); my $filename = $self->script_filename; my $result = LIMS::Model::Email->send_message($mail); # Return::Value object if ( $result->type eq 'success' ) { my $email = $mail->{recipient}; printf "%s reports %s to %s\n", $filename, lc $result->string, $email; return 1; } else { # failure printf "%s reports %s\n", $filename, $result->string; warn "$filename error: " . $result->string; return 0; } } sub path_to_app_root { my $path = shift->use_path() || $Bin . '/../../..'; # warn $path; return $path; } sub mail_admin { my ($self, $args) = @_; my $cfg = $self->config; my $recipient = $cfg->{sysadmin_email}; my $message = $args->{msg}; # use specified subject, or create default: my $subject = $args->{subject} || 'Error message from ' . $args->{script}; my %mail = ( recipient => $recipient, message => $message, subject => $subject, config => $cfg, ); # warn Dumper \%mail; return; my $rtn = LIMS::Model::Email->send_message(\%mail); # Return::Value object if ($rtn->type ne 'success') { my $filename = $self->script_filename; warn "$filename error: " . $rtn->string; } } sub log_diagnosis_alert { my ($self, $args, $recipients) = @_; return 0 if $self->test_only(); # don't log to request_history if just testing my $dbix = $self->dbix(); RECIPIENT: foreach my $recipient (@$recipients) { # warn $recipient; my $addr = $self->recipient_address($recipient); unless ($addr) { # in case it doesn't exist my $filename = $self->script_filename; warn "$filename: can't find address for $recipient"; next RECIPIENT; } my %local = %$args; # take local copy of $args $local{action} = $args->{action} . ' to ' . $addr; # append addr to action $dbix->insert('request_history', \%local); # warn Dumper \%local; } } sub recipient_address { my ($self, $recipient) = @_; my $secure_contacts = $self->secure_contacts(); # warn Dumper $secure_contacts; my $user_emails = $self->user_emails(); my $addr = ( $recipient =~ /\.secure\Z/ ) # these require nhs.net address: ? $secure_contacts->{$recipient} # non-secure address, either from hilis4.users table, # or contacts.lib also has some non-HILIS users addresses: : ( $user_emails->{$recipient} || $secure_contacts->{$recipient} ); return $addr; } sub script_filename { my $self = shift; my $caller = $0; # warn Dumper $caller; my $filename = io($caller)->filename; # returns filename part of full/path/to/filename my $formatter = DateTime::Format::Strptime->new( pattern => '%Y-%m-%d %T' ); return sprintf '%s [%s]', $filename, $self->time_now({ formatter => $formatter }); } sub time_now { my $self = shift; my $args = shift; # optional args hashref for DT constructor return LIMS::Local::Utils::time_now($args); # considers BST } sub date_subtract { my $self = shift; my ($period, $int, $args) = @_; # eg months, 6, optional args for DT->new my $today = $self->time_now($args); return $today->subtract($period, $int); } sub _build_dbix { my $self = shift; # get db connection params from config file my $cfg = $self->config; # warn Dumper $cfg; my $uid = $cfg->{db_user_id}; my $pwd = $cfg->{db_password}; my $db = $cfg->{production_db}; my $dsn = "dbi:mysql:$db"; my @args = ( $dsn, $uid, $pwd, { RaiseError => 1 } ); my $dbix = LIMS::Local::DBIxSimple->connect(@args); return $dbix; } sub _build_secure_contacts { my $self = shift; my $src_file = $self->path_to_app_root . '/src/lib/contacts.lib'; my $contacts = Config::Auto::parse($src_file); return $contacts; } sub _build_user_emails { my $self = shift; return $self->dbix->query('select username, email from users')->map; } sub _build_config { # returns config 'settings' data my $self = shift; my $lims_config = LIMS::Local::Config->instance; # warn Dumper $lims_config; my $settings = $lims_config->{settings}; # add path_to_app_root (not already in $settings): $settings->{path_to_app_root} = $lims_config->{path_to_app_root}; return $settings; } sub _build_template { my $self = shift; my $t = Template->new({ INCLUDE_PATH => $self->path_to_app_root . '/templates' }); return $t; }