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 %h; while (my $test = $o->next) { # $self->debug($test->as_tree); next if $test->active eq 'no'; my $description = $test->description; # $self->debug($description); my $category = $test->category->name; # $self->debug($category); push @{ $h{$category}{$description} }, $test; } $self->tt_params( data => \%h ); 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 list_ngis_excluded_tests : Runmode { my $self = shift; $self->_debug_path($self->get_current_runmode); my $ref = $self->get_yaml_file('ngis_excluded_lab_tests'); # warn Dumper $ref; $self->tt_params( data => $ref ); 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_sub_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 $status = $self->model('Base')->does_authorisation() ? 'authorised' : 'reported'; # warn $status; my $query = [ option_name => 'teaching', action => $status, 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 (retain $_ for legacy): 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 passed from 'hello' page or specific report view: if ( my $recipient_id = $self->param('id') ) { my $user = $self->model('User')->get_user_profile($recipient_id); $self->tt_params( recipient => $user ); } else { # Resources / User message link: 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 ); } } # pm from a specific report view: if ( my $request_id = $self->param('Id') ) { my $request = $self->model('Request')->get_request($request_id); $self->tt_params( request => $request ); } 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 resend_hl7 : Runmode { my $self = shift; if ( $self->query->param('confirm_resend') ) { my $cmd = path( $self->cfg('path_to_app_root'), qw/script crons daily nbt_ice7.pl/ ); # warn $cmd; # send -r flag to force (r)esponse output: my $result = `$cmd -r`; # p $result; # run(x), cature(x), etc don't work here !! $self->tt_params( result => $result ); } return $self->tt_process(); } # ------------------------------------------------------------------------------ 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;