package LIMS::Controller::Resources;
use Moose;
BEGIN { extends 'LIMS::Base'; }
with (
'LIMS::Controller::Roles::Misc',
'LIMS::Controller::Roles::Aspell',
'LIMS::Controller::Roles::DataMap',
'LIMS::Controller::Roles::DataFile',
'LIMS::Controller::Roles::Resource',
'LIMS::Controller::Roles::Dashboard',
);
__PACKAGE__->meta->make_immutable(inline_constructor => 0);
use IPC::System::Simple qw(system capture);
use CGI::Session;
use Data::Dumper;
use Path::Tiny;
use IO::All;
#-------------------------------------------------------------------------------
sub menu : StartRunmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
# for centre & username for handing to .cgi scripts as param
my $token = $self->create_form_tokens();
return $self->tt_process({ token => $token });
}
#-------------------------------------------------------------------------------
sub list_all_screen_tests : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $o = $self->model('Screen')->get_all_assigned_tests;
my %tests;
while (my $test = $o->next) { # $self->debug($test->as_tree);
next if $test->screen->active eq 'no';
my $section_name = $test->lab_test->lab_section->section_name;
my $description = $test->screen->description;
my $field_label = $test->lab_test->field_label;
my $category = $test->screen->category->name,
my %data = (
section_name => $section_name,
field_label => $field_label,
);
push @{ $tests{$category}{$description} }, \%data;
}
$self->tt_params( data => \%tests );
return $self->tt_process;
}
#-------------------------------------------------------------------------------
sub diagnosis_context_warnings : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
$self->load_diagnosis_context_warnings(); # doesn't return, just adds tt_params
return $self->tt_process('admin/config/diagnosiscontextwarnings/default.tt');
}
#-------------------------------------------------------------------------------
sub diagnosis_generated_lab_tests : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $data = do {
my @rels = qw/diagnosis lab_test.lab_section/;
$self->model('Base')->get_objects('DiagnosisLabTest', {}, \@rels);
};
my %h;
for my $ref (@$data) {
my $diagnosis = $ref->diagnosis->name;
my $lab_test = $ref->lab_test->field_label;
my $section = $ref->lab_test->lab_section->section_name;
push @{ $h{$diagnosis} }, { test => $lab_test, section => $section };
# push @{ $h{$diagnosis} }, { $lab_test => $section }; # how to use in tt ?
} # warn Dumper \%h;
return $self->tt_process({ data => \%h });
}
#-------------------------------------------------------------------------------
sub results_summary_generated_lab_tests : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $data = do {
my @rels = qw/result_summary lab_test.lab_section/;
$self->model('Base')->get_objects('ResultSummaryLabTest', {}, \@rels);
};
my %h;
for my $ref (@$data) {
my $summary = $ref->result_summary->description;
my $lab_test = $ref->lab_test->field_label;
my $section = $ref->lab_test->lab_section->section_name;
push @{ $h{$summary} }, { test => $lab_test, section => $section };
# push @{ $h{$summary} }, { $lab_test => $section }; # how to use in tt ?
} # warn Dumper \%h;
return $self->tt_process({ data => \%h });
}
#-------------------------------------------------------------------------------
sub list_all_lab_tests : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $sort_by = $self->query->param('sort_by') || '';
{ # lab tests:
my $o = $self->model('LabTest')->get_all_active_lab_tests($sort_by);
$self->tt_params( lab_tests => $o );
}
{ # lab sections:
my $o = $self->model('LabSection')->get_lab_sections;
$self->tt_params( lab_sections => $o );
}
return $self->tt_process();
}
#-------------------------------------------------------------------------------
sub list_linked_lab_tests : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
# get current linked lab-tests:
my @joins = ('parent_lab_test.lab_section', 'linked_lab_test.lab_section');
my $args = { sort_by => 'parent_lab_test.field_label' };
my @args = ( 'LinkedLabTest', $args, \@joins );
my $linked_tests = $self->model('Base')->get_objects(@args);
$self->tt_params( data => $linked_tests );
return $self->tt_process;
}
#-------------------------------------------------------------------------------
sub diagnostic_terms : Runmode {
my $self = shift;
my %args = ( sort_by => $self->query->param('sort_by') || '' );
my $total = $self->model('Base')->get_objects_count('Diagnosis');
if ( $total > $self->cfg('settings')->{entries_per_page} ) {
# invoke pager for template and add limit & offset params to \%args:
$self->pager({ query => \%args, total => $total });
}
{ # get all diagnoses:
my $diagnoses = $self->model('Diagnosis')->get_all_diagnoses(\%args);
$self->tt_params( diagnoses => $diagnoses );
}
{ # ICDO3 category - maps ICDO3 to sub-groups (AML, CLL, MCL, etc):
my $sub_categories = $self->get_icdo_category(); # L::C::R::Misc
$self->tt_params( sub_categories => $sub_categories );
}
return $self->tt_process;
}
#-------------------------------------------------------------------------------
sub teaching_cases : Runmode {
my $self = shift;
my $duration = $self->query->param('duration') || 365; # days default
$self->stash( duration => $duration ); # for .tt
my $time_now = LIMS::Local::Utils::time_now();
my $query = [
option_name => 'teaching',
action => 'authorised',
time => { ge => $time_now->subtract( days => $duration ) },
];
my @objects = ('request_history', 'request_option.option');
# args = classname, optional hashref of args, optional with_objects:
my @args = ('Request', { query => $query, multi_many_ok => 1 }, \@objects);
my $total = $self->model('Base')->get_objects_count(@args); # warn Dumper $total;
if ( $total > $self->cfg('settings')->{entries_per_page} ) {
# invoke pager for template and add limit & offset params to \%args:
$self->pager({ query => {}, total => $total });
}
my $data = $self->model('Audit')->teaching_cases($duration);
$self->tt_params(
cases => $data,
start_date => $self->model('Request')->get_first_request_date(),
);
return $self->tt_process;
}
#-------------------------------------------------------------------------------
sub view_cron_log : Runmode {
my $self = shift;
my $file = $self->cfg('settings')->{cron_log_path} . '/cron.log';
my @log = io($file)->slurp;
# add flag for any lines which look like an error:
my $err_flag = '#%=ERROR=%#';
map { $_ .= $err_flag unless $_ =~ /^([\w_-]+\.pl)/ } @log; # alphanum, hyphen, underscore
$self->tt_params(
err_flag => $err_flag,
data => \@log,
);
return $self->tt_process();
}
#-------------------------------------------------------------------------------
sub dashboard : Runmode { # some static data, tt calls highchart/sparklets as ajax
my $self = shift; $self->_debug_path($self->get_current_runmode);
$self->dashboard_view(); # populates $self->dashboard_data
return $self->tt_process({ data => $self->dashboard_data });
}
#-------------------------------------------------------------------------------
sub incomplete_tests : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $lab_section = $self->query->param('section'); # warn $lab_section;
my $field_label = $self->query->param('investigation'); # warn $field_label;
my %args = (
section_name => $lab_section,
field_label => $field_label,
);
my $data = $self->model('LabTest')->get_incomplete_request_lab_tests(\%args);
return $self->tt_process({ dataset => $data });
}
# ------------------------------------------------------------------------------
sub check_speller_words : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $src = $self->get_speller_tempfile(); # warn $src;
# get list of unique words from temp file:
my %words = map +($_ => 1), io($src)->chomp->slurp; # warn Dumper \%words;
$self->tt_process({ words => [ sort keys %words ] });
}
# ------------------------------------------------------------------------------
sub update_user_dictionary : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $url = $self->query->url . '/resources/check_speller_words';
my @words = $self->query->param('word'); # warn Dumper \@words;
unless (@words) {
$self->stash( error => 'no words submitted' );
return $self->redirect($url);
}
my $speller = $self->speller(); # $speller->print_config;
$speller->add_to_personal($_) for @words;
if ( $speller->save_all_word_lists ) { # fails with $speller->errstr;
my $src = $self->get_speller_tempfile($speller); # warn $src;
# split entry on '~', discard username, only want word:
my %all = map { (split '~')[1] => 1 } io($src)->chomp->slurp; # warn Dumper \%all;
# delete successful updates:
delete $all{$_} for @words; # warn Dumper \%all;
$self->tt_params( trashed => \%all );
io($src)->print(); # reset file empty
}
else {
$self->stash( error => $speller->errstr );
return $self->redirect($url);
}
return $self->tt_process({ words => \@words });
}
# ------------------------------------------------------------------------------
sub query_view : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $view = $self->param('id');
my $sort = $self->query->param('sort_by'); # optional, not loaded on initial view
my $data = $self->model('Local')->load_view($view, $sort); # hashref (keys = data & cols)
return $self->tt_process( $data );
}
# ------------------------------------------------------------------------------
sub admin_messages : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $data = $self->get_admin_messages(); # R::Resources; no args for 'all' msgs
$self->tt_params( msgs => $data );
return $self->tt_process();
}
# ------------------------------------------------------------------------------
sub edit_admin_message : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $msg_id = $self->param('id');
my $params = $self->query->Vars; # warn Dumper $vars;
if (%$params) { # update of existing entry
$self->model('')->update_admin_message($params);
return $self->redirect( $self->qurey->url . '/resources/admin_messages');
}
else { # get requested entry:
my $data = $self->get_admin_messages(); # R::Resources; no args for 'all' msgs
# get requested entry from @$data array:
my ($msg) = grep $_->id == $msg_id, @$data; # warn Dumper $msg;
$self->tt_params( msg => $msg );
return $self->tt_process();
}
}
#-------------------------------------------------------------------------------
sub outreach_practice_blood_tube_overrides : Runmode {
my $self = shift;
my $data = $self->model('Outreach')->practice_blood_tube_overrides;
return $self->tt_process({ data => $data });
}
#-------------------------------------------------------------------------------
sub view_sysmex_log : Runmode {
my $self = shift;
my $file = $self->cfg('path_to_app_root') . '/logs/sysmex.log';
my $data = _parse_sysmex_data($file); # warn Dumper $data;
return $self->tt_process({ data => $data });
}
sub _parse_sysmex_data {
my $file = shift;
my @data = io($file)->slurp;
my @fields = qw(
pda wbc wbc_f rbc rbc_f hb hb_f hct hct_f mcv mcv_f mch mch_f mchc mchc_f
plt plt_f lymph_percent lymph_percent_f mixed_percent mixed_percent_f
neutr_percent neutr_percent_f lymph lymph_f mixed mixed_f neutr neutr_f
);
my @results = ();
my ($datetime, $id, @params);
for (reverse @data) { # latest 1st
# alternate lines datatime & data:
if ($_ =~ /D1U/) { # warn 'here';
($id, @params) = $_ =~ m!
D1U\d{15} # year, month, day + sample ID padding (7 zeros)
(.{9}) # sample ID (9 chars)
(\w{6}) # PDA info
\d # RDW select || reserve
([\d*]{4})(\d) # wbc + flag
([\d*]{4})(\d) # rbc + flag
([\d*]{4})(\d) # hb + flag
([\d*]{4})(\d) # hct + flag
([\d*]{4})(\d) # mcv + flag
([\d*]{4})(\d) # mch + flag
([\d*]{4})(\d) # mchc + flag
([\d*]{4})(\d) # plt + flag
([\d*]{4})(\d) # lymph (%) + flag
([\d*]{4})(\d) # mixed (%) + flag
([\d*]{4})(\d) # neutr (%) + flag
([\d*]{4})(\d) # lymph (#) + flag
([\d*]{4})(\d) # mixed (#) + flag
([\d*]{4})(\d) # neutr (#) + flag
# .*{5} # rdw - don't need
# .*{5} # pdw - don't need
# .*{5} # mpv - don't need
# .*{5} # p-lrc - don't need
!xo; # warn Dumper [$id, \@params ];
}
if (/(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2})/) { # warn 'here';
$datetime = $1; # warn $datetime;
}
if ($datetime && $id && @params) { # warn Dumper [$datetime, $id, \@params];
my %h = (); # reset
# create hash of data:
@h{@fields} = @params; # warn Dumper \%h;
# add labno/id & datetime:
@h{ qw(id datetime) } = ( $id, $datetime );
push @results, \%h;
$datetime = $id = undef; @params = (); # reset
}
} # warn Dumper \@results;
return \@results;
}
#-------------------------------------------------------------------------------
sub data_file : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $errs = shift;
return $self->forbidden() unless $self->user_can('do_admin');
return $self->tt_process('resources/new_data_file.tt', { error => $errs });
}
#-------------------------------------------------------------------------------
sub active_sessions : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
# args = classname, optional hashref of args, optional with_objects:
my @args = ('Session', { sort_by => 'time desc' }, 'user.user_location');
my $all_sessions = $self->model('Base')->get_objects(@args);
my $settings = $self->cfg('settings');
my $timeouts = $self->get_yaml_file('idle_timeout'); # warn Dumper $timeouts;
my @active_sessions = ();
my @cgi_sess_cfg = (
'driver:MySQL;serializer:'.$settings->{db_session_serializer},
undef, # placeholder for session id,
{ Handle => $self->dbh },
1, # THIS IS EXPERIMENTAL: pass a true value as the fourth parameter if
# you want to skip the changing of access time. This isn't documented
# more formally, because it only called by find() [works OK in v4.43]
);
SESSION:
for my $session (@$all_sessions) {
next unless $session->userid; # skip failed logins & not logged in yet
$cgi_sess_cfg[1] = $session->id; # set session id
my $sess = CGI::Session->load(@cgi_sess_cfg); # load() doesn't force new
# warn Dumper [ $sess->atime, $sess->ctime, $sess->expire, time() ];
my $user_location = $session->user->user_location->location_name;
my $timeout # if user location in idle_timeout.yml, or default:
= $timeouts->{$user_location} || $settings->{default_user_timeout};
# push @active_sessions, $session
# unless $sess->is_expired; # no, this is CGI::Session timeout (24hrs)!
if ( my $atime = $sess->atime ) { # to prevent unititialized val in subtraction err
my $session_is_expired = ( time() - $atime > $timeout );
# warn Dumper [ time() - $sess->atime, $timeout ];
next SESSION if $session_is_expired; # warn Dumper $session->as_tree;
my %data = (
addr => $sess->remote_addr,
user => $session->user,
time => $session->time,
); # warn Dumper \%data;
push @active_sessions, \%data;
}
}
$self->tt_params( sessions => \@active_sessions);
{ # callback for template to calculate duration:
my $duration = sub {
LIMS::Local::Utils::time_now->delta_ms(@_);
};
$self->tt_params( calculate_duration => $duration );
}
return $self->tt_process;
}
#-------------------------------------------------------------------------------
sub get_data_file : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
return $self->forbidden() unless grep $self->user_can($_),
qw(do_admin edit_pid); # edit_pid from referral_sources lookup page
my $method = $self->query->param('method'); # warn $method;
if ($method eq 'url') {
return $self->data_file_from_url; # Role::DataFile
}
elsif ($method eq 'upload') {
return $self->data_file_from_upload; # Role::DataFile
}
else {
return $self->forward('data_file');
}
}
#-------------------------------------------------------------------------------
sub user_messages : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $errs = shift; # warn Dumper $errs;
if ( my $recipient_id = $self->param('id') ) { # if passed from 'hello' page
my $user = $self->model('User')->get_user_profile($recipient_id);
$self->tt_params( recipient => $user );
}
else {
my $profile = $self->user_profile;
$self->js_validation_profile('user_message');
{ # get any user-to-user messages:
my $messages = $self->get_user_messages($profile->{id});
$self->tt_params( user_messages => $messages );
}
{ # get any admin-to-user messages:
my $user_location = $profile->{user_location}->{location_name};
my $messages = $self->get_admin_messages($user_location);
$self->tt_params( admin_messages => $messages );
}
{ # get list of user_locations with at least one active user:
my $o = $self->model('User')->get_active_user_locations();
$self->tt_params( user_locations => $o );
}
}
return $self->tt_process($errs);
}
#-------------------------------------------------------------------------------
sub new_message : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $dfv = $self->check_rm('user_messages', $self->validate('user_message') )
|| return $self->dfv_error_page;
my $data = $dfv->valid(); # $self->debug($data);
my $rtn = $self->model('User')->new_user_message($data);
if ($rtn) {
return $self->error($rtn);
}
else {
$self->flash( info => $self->messages('user')->{msg_sent});
return $self->redirect( $self->query->url . '/resources/user_messages' );
}
}
#-------------------------------------------------------------------------------
sub new_diagnoses : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $profile = $self->user_profile; # warn Dumper $profile;
my $vars = $self->query->Vars(); # warn Dumper $vars;
my $data = $self->new_and_relapsed_diagnoses($vars); # warn Dumper $data;
my $locations = {}; # can be all locations, local network, single location, or none:
if ( $self->is_lab_staff ) { # can view all locations
$locations = $data->{locations_map};
}
elsif ( my $network_locations = $self->get_network_locations ) { # C::R::Resource
$locations = $network_locations; # eg East Lancs network
}
elsif ( my $region_code = $profile->{user_location}->{region_code} ) { # warn $region_code;
my $h = $data->{locations_map}; # delete all but users' location:
( $h->{$_} eq $region_code ) or delete $h->{$_} for keys %$h; # works as it's a ref to hash
$locations = $data->{locations_map}; # now should only have users' location
} # warn Dumper $locations; # may still be undef eg user location has no region code
$self->tt_params(
locations => $locations,
results => $data->{results},
);
return $self->tt_process();
}
#-------------------------------------------------------------------------------
sub user_permissions : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
my $data = $self->model('User')->display_user_permissions; # warn Dumper $data;
# need to get hash of function.id for unlock_actions (edit_pid, report, etc):
my $unlock_actions = $self->cfg('unlock_actions');
my $all_functions = $self->model('User')->get_user_functions();
# get hash of function_name => id for user_functions table:
my %functions = map +( $_->function_name => $_->id ), @$all_functions;
# warn Dumper \%functions;
# take %functions hash slice into new hash:
my %unlock_actions_map = map +($_ => 1), @functions{@$unlock_actions};
# warn Dumper \%unlock_actions_map;
my %tt_params = (
data => $data,
functions => $self->user_functions_map,
unlock_actions => \%unlock_actions_map,
);
return $self->render_view('resources/user_permissions.tt', \%tt_params);
}
# ------------------------------------------------------------------------------
sub process_status : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
if ( my $pid = $self->query->param('pid') ) { # request to kill process
# redirect url coz we've just killed process handling this request:
my $url = $self->query->url . '/resources/process_status'; # path_info unreliable
system 'kill -9 ' . $pid; # warn Dumper \@pids;
# doesn't always work - sometimes get fatal 'incomplete headers':
$self->redirect($url);
}
my $cmd = 'ps aux | grep -v grep | grep perl'; # gets pids in numerical order
my @ps = capture($cmd); # warn Dumper \@ps;
# get list of .pid files and their ppid (parent process id):
my $run_dir = $self->cfg('settings')->{run_dir};
my %pp_ids = map +( $_->getline => $_->filename ),
grep { $_->filename =~ /\w+\.pid$/ }
io($run_dir)->all_files; # warn Dumper \%pids;
my %vsz;
# get child processes for each parent pid (using method from kidreaper script):
for my $ppId (keys %pp_ids) { # warn $ppid;
my $cmd = sprintf '/bin/ps -o pid=,vsz= --ppid %s|', $ppId;
if ( open my $kids, $cmd ) {
while (<$kids>) {
chomp;
my ($cpId, $mem) = split; # warn Dumper [$cpId, $mem];
$vsz{$cpId} = {
parent => $pp_ids{$ppId},
vsz => $mem,
};
}
}
} # warn Dumper \%vsz;
my %data;
for (@ps) {
my @fields = split /\s+/; # warn Dumper \@fields;
my ($user,$pid,$cpu,$mem_percent,$vsv,$rss,$start,$time,$cmd)
= @fields[0..5,8..10];
next unless $cmd =~ /^perl-fcgi/; # cmd matches perl-fcgi
my $memory = $vsz{$pid}{vsz} || $vsv; # $vsv if parent
my $type = $cmd eq 'perl-fcgi-pm' ? 'parent' : 'child';
my %h = (
percent => $mem_percent,
start => $start,
user => $user,
time => $time,
type => $type,
pid => $pid,
cpu => $cpu,
);
# format for clarity:
$h{vmem} = _number_format($memory);
$h{rss} = _number_format($rss);
# get name of parent process either from %pids, or child processes:
my $parent = $pp_ids{$pid} || $vsz{$pid}{parent} || 'orphan';
$parent =~ s/(\w+)\.pid/$1/; # remove trailing '.pid'
push @{ $data{$parent} }, \%h;
}
return $self->tt_process({ data => \%data, cmd => $cmd });
}
# ------------------------------------------------------------------------------
sub system_resources : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
# callback for CPU load:
$self->tt_params( cpu => \&_cpu_data );
return $self->tt_process();
}
sub _cpu_data { # from webmin/proc/linux-lib.pl os_get_cpu_info()
open my $src, '<' . '/proc/loadavg' || return 0;
my @load = split /\s+/, <$src>;
return @load[0..2];
}
sub _number_format { # www.perlmonks.org/?node_id=653
local $_ = shift;
# $_ /= 1024; # to MB
1 while s/^(-?\d+)(\d{3})/$1_$2/;
return $_;
}
1;
