package LIMS;
=begin # doesn't work under production env
use vars '$svk_revision';
BEGIN { # get svk equivalent of svnversion - hit only once during startup:
unless ($ENV{HARNESS_ACTIVE}) { # crashes it
$svk_revision = `svk info | grep 'Revision:' | awk '{print \$2}'`;
}
}
our $VERSION = $svk_revision;
=cut
use Moose;
extends 'LIMS::Titanium';
with (
# 'LIMS::Model::Roles::QueryLogger',
'LIMS::Role::Base', # render_view(), model()
'LIMS::Controller::Roles::DataMap',
'LIMS::Controller::Roles::Resource',
);
use IO::All;
use Data::Dumper;
use Time::HiRes qw(gettimeofday tv_interval);
use DateTime; DateTime->DefaultLocale('en_GB'); # set default locale for app
use Scalar::Util qw(weaken);
# use Memory::Usage;
# use POSIX qw(strftime); # only required by CAP::LogDispatch callback
# use Devel::Gladiator qw(arena_ref_counts arena_table);
use LIMS::RDBO; # returns LIMS::DB->new_or_cached via init_db()
use LIMS::Validate; # returns validation profile
use LIMS::Local::Debug;
use LIMS::Local::Utils;
use LIMS::Local::Config;
use LIMS::Local::QueryLog qw( set_querylog_args );
use LIMS::Local::LogDispatch;
=begin # test don't work -
sub cgiapp_get_query {
my $self = shift;
require CGI::Simple; # note, uploads are disabled by default in CGI::Simple
return CGI::Simple->new();
}
=cut
#-------------------------------------------------------------------------------
# OVERRIDE METHODS
#-------------------------------------------------------------------------------
sub cgiapp_init {
my $self = shift; # DEBUG $self->query; # needs to be after Log::Dispatch setup
if ($self->{have_turned_dbi_trace_on}) { # eg in fcgi script - comment to enable
my $msg = sprintf 'PID: %s; TIMESTAMP: %s',
$$, DateTime->now( time_zone => 'local' )->datetime;
DBI->trace_msg($msg, 0); # warn $msg;
}
=begin # Memory::Usage:
$self->{mu} = Memory::Usage->new();
$self->{mu}->record('cgiapp_init');
=cut
# set Time::HiRes base-line; needs to be before Log::Dispatch setup
$self->param( t0 => [gettimeofday] );
# configure plugins:
$self->_configure_plugins;
# configure CAP::Authentication protected_runmodes:
$self->_configure_protected_runmodes;
$self->debug($self->query); # needs to be done after plugin config
}
#-------------------------------------------------------------------------------
sub setup {
my $self = shift;
$self->run_modes(
login => 'login',
offline => 'offline',
AUTOLOAD => \&_exception,
); # warn Dumper $self->run_modes;
}
#-------------------------------------------------------------------------------
sub cgiapp_prerun {
my $self = shift;
# load this if using non-external fastcgi (see comment in L::L::QueryLog)
# LIMS::Local::QueryLog->ensure_warn_handler_capture;
=begin
$Data::Dumper::Deparse = 1; # warn Dumper $SIG{__WARN__};
use Sub::Identify ':all';
my $subname = sub_fullname( $SIG{__WARN__} ); warn $subname;
=cut
# $self->param(arena_ref_counts_pre => arena_ref_counts()); # and _log_process_size
my $authen = $self->authen; # $self->_dump_authen_params;
my $query = $self->query;
# temporarily force logged-in users to holding page in offline mode:
$self->prerun_mode('offline') if $authen->username
&& $self->config('settings')->{offline};
# check access route is permitted (ie direct or via portal):
=begin # combined with login form now
unless ( $self->_check_portal_referral ) { # warn 'here';
my $home_page = sprintf '/%s.html', $query->url(-relative => 1);
return $self->redirect( $home_page ); # hilis4.html, hods.html, etc
}
{ # some locations can skip terms & conditions - simplified login so not needed:
my $local_addr = $self->get_yaml_file('local_addr'); # warn Dumper $permitted;
my $var = grep { $ENV{REMOTE_ADDR} =~ /^$_/ } @$local_addr;
$self->tt_params( can_bypass_terms => $var );
}
=cut
$self->tt_params( # keep this *ABOVE* main if() block below !!
app_url => $query->url,
url_base => $query->url(-base=>1),
url_with_path => $query->url(-path_info=>1),
remote_addr => $ENV{REMOTE_ADDR},
);
{ # pass username to ErrorHandler & QueryLog (*BEFORE* main if() block below):
my $args = { user => $self->authen->username || '' }; # '' in case no username yet
LIMS::Local::QueryLog::set_querylog_args($args);
LIMS::Local::ErrorHandler::set_errorhandler_args($args);
}
# if new login, need to see if user profile exists (ie genuine new login), or
# re-login after idle timeout (need to check username matches session profile):
if ( $authen->is_new_login ) { # warn 'here' . '=' x 20;
# get user profile (if it exists):
my $profile = $self->user_profile; # warn Dumper $profile;
my $username = $authen->username;
if (! $profile) { # it's a new login
$self->_create_user_profile(); # warn 'here' . '=' x 20;
# my $vars = $query->Vars(); warn Dumper $vars;
# redirect to 'hello' page, unless destination already set in login():
# my $skip_redirect = grep $vars->{$_}, qw(skip_redirect destination); # don't need skip_redirect
unless ( $self->query->param('destination') ) { # warn 'here' . '=' x 20;
# re-direct to 'hello' page:
my $redirect = 'login/hello';
return $self->redirect( $query->url . '/' . $redirect );
}
# else { warn 'here' . '=' x 20 } # no redirect param supplied
}
# check form param username matches session profile, or redirect to logout:
elsif ( $username ne $profile->{username} ) { # warn 'here' . '=' x 20;
# $self->flash(); # can't do it - lost on logout(); not needed as never get here
# warn Dumper [$self->authen->username, $profile->{username}];
$self->redirect( $query->url . '/logout' );
}
# check email address present (legacy conversion):
elsif (! $profile->{email} ) { # warn 'here' . '=' x 20;
$self->flash( warning => $self->messages('user')->{update_email} );
}
# check new messages (not needed - now calling ajax function from .tt):
# elsif ( my $i = $self->model('User')->any_new_messages($username) ) {
# set flash msg:
# my $msg = $self->tt_process('user/new_msg_alert.tt', {count => $i});
# $self->flash( info => ${$msg} );
# }
# else { warn 'here' . '=' x 20 } # is_new_login & has user_profile & usernames match
}
# not a new login but session has timed out:
elsif ( $authen->is_login_timeout ) { # warn 'here' . '=' x 20; # warn $self->query->url;
#my $log = $self->cfg->{path_to_app_root} . '/logs/destination.log'; # warn $log;
#my $q = $self->query;
#my $msg = join '; ', $q->request_method(), $q->self_url() . "\n";
#io($log)->append($msg);
}
# else { warn 'here' . '=' x 20 } # not new login & session not timed out (majority of hits)
# for colourising tabs in tt display:
$self->_set_active_link(); # uses tt_params - won't work on a redirect
# otherwise CAD-loaded classes can't find it for package-wide authorization:
$self->run_modes( authz_forbidden => 'forbidden' );
# alternative to $self->authen->protected_runmodes:
# $self->authen->username ?
# $self->authen->redirect_after_login :
# $self->authen->redirect_to_login;
}
#-------------------------------------------------------------------------------
sub cgiapp_postrun {
my ($self, $output) = @_; # warn Dumper $output;
my $run_time = sprintf "%.2f sec",
tv_interval $self->param('t0'), [gettimeofday];
${$output} =~ s/%SCRIPTRUNTIMER%/$run_time/; # too late to use tt_params
# $self->_log_process_size();
}
=begin # to manipulate info pre tt_process:
sub tt_pre_process {
my ($self, $file, $vars) = @_; warn Dumper $vars;
$vars->{remote_user} = $ENV{REMOTE_USER};
return;
}
=cut
#-------------------------------------------------------------------------------
sub teardown {
my $self = shift;
$self->session->flush; # recommended action
# README: need to update sessions table with userid on new login and also on
# re-authentication after a session timeout - CAP::Authen seems to delete
# session on timeout (see sql log), and a new one is created in final call
# to CGI::Session::flush (see last item in a DBI trace), which calls
# CGI::Session::Driver::mysql::store and creates a new session with same ID,
# and preserves a_session UserProfile vals (deletes all AUTH_* fields), but
# also ignores userid col. So need to update it again after flush():
if ( $self->authen->is_new_login ) { # warn 'new login/re-authentication';
my $args = {
session_id => $self->session->id,
userid => $self->authen->username,
};
$self->model('User')->update_session_userid($args); # warn Dumper $args;
}
# no need to send fastcgi process to find_cycle() - ran for 2 weeks in 03/2016 - zero instances
if ( grep $ENV{$_}, qw/DEVEL_SERVER HARNESS_ACTIVE/ ) { # warn 'here'; # for devel/testing only:
my @no_devel_cycle = qw(_do_print); # takes minutes !!
unless ( grep $self->get_current_runmode eq $_, @no_devel_cycle ) { # warn 'here';
require LIMS::Local::DevelCycle; # warn Devel::Cycle::find_cycle($self);
if ( my $out = LIMS::Local::DevelCycle::find($self) ) { die $out }
}
}
=begin # Memory::Usage:
$self->{mu}->record('teardown');
my $r = $self->{mu}->report(); # $self->{mu}->dump();
$self->debug($r);
=cut
}
#-------------------------------------------------------------------------------
# for model methods, return (or if 1st call then create & return) a db object:
sub lims_db { shift->{__lims_db} ||= LIMS::RDBO->init_db } # should be the *only* call in whole app
sub dbh { shift->lims_db->dbh } # for Controller methods requiring the dbh eg session_config()
sub user_profile { shift->authen->store->fetch('yooza_profile') } # session param
#-------------------------------------------------------------------------------
# drop-in replacements for CAP::ConfigAuto (cfg & config) - using L::Local::Config now
sub config {
my $self = shift;
my $cfg = LIMS::Local::Config->instance;
if (@_) {
my $section = shift;
return $cfg->{$section};
}
else {
return $cfg;
}
}
# alias for config() used by CAP::ConfigAuto:
sub cfg { shift->config(@_) }
# temporary holding page for offline / maintenance mode:
sub offline { return shift->_offline_mode }
#-------------------------------------------------------------------------------
# RUNMODES
#-------------------------------------------------------------------------------
sub login {
my $self = shift; # warn $self->query->url(-path_info=>1);
# whitelist of permitted destinations on new login or session timeout
# re-authentication, otherwise redirects to default runmode (eg /search)
# don't need destination urls for 1st login or password reset emails
my @permitted = (
'/search/[=\w+]', # allows '=', notification, do_search - all are safe
'/request/print_record',
);
# load full query eg do_search?patient_id=1000 ie self_url():
$self->tt_params( destination_url => $self->query->self_url ) if
uc $self->query->request_method eq 'GET' && # disallow any POSTs
grep $self->query->url(-path_info=>1) =~ /$_/, @permitted;
if ( $self->authen->is_login_timeout ) { } # if needing to modify
# for idle timeout re-authentication:
if ( my $profile = $self->user_profile ) { # warn Dumper $profile;
$self->tt_params( user_profile => $profile );
}
$self->tt_params( env => \%ENV );
$self->_limerick();
return $self->tt_process('login/default.tt');
}
#-------------------------------------------------------------------------------
# PRIVATE METHODS
#-------------------------------------------------------------------------------
sub _configure_plugins {
my $self = shift;
# load config from config file:
my $cfg = $self->cfg;
#-------------------------------------------------------------------------------
# override default template_name_generator method:
$cfg->{tt_config}->{TEMPLATE_NAME_GENERATOR} = _tmpl_name_generator(); # should be able to do this in config?
# $self->tt_config( $cfg->{tt_config} ); # now loading TT as class method
__PACKAGE__->tt_config( $cfg->{tt_config} ); # (singleton) instead of object method
#-------------------------------------------------------------------------------
# configure CAP::Session - uses CGI::Session; gets cookie or hidden field
# session id from $cgi; add CGI_SESSION_OPTIONS (cgi method, session driver,
# etc) to session_config():
$cfg->{session_config}->{CGI_SESSION_OPTIONS} = $self->_set_cgisession_options();
$self->session_config( %{ $cfg->{session_config} } );
#-------------------------------------------------------------------------------
# configure CAP::Authentication:
my $authen_cfg = $self->_authen_config(); # doesn't work in lims_config if using instance()
$self->authen->config($authen_cfg);
#-------------------------------------------------------------------------------
# ValidateRM/DFV config:
$self->param( dfv_defaults => $cfg->{dfv_defaults} );
#-------------------------------------------------------------------------------
# CAP::MessageStack config; *must* have YAML::Syck installed if using yaml serializer:
$self->capms_config(
-automatic_clearing => 1, # removed from session after display
-classification_param_name => 'class', # default = 'classification'
);
#-------------------------------------------------------------------------------
FormValidator::Simple->set_messages( $self->messages('form_validator') );
#-------------------------------------------------------------------------------
# configure CAP::Authorization:
# push @{ $cfg->{authz_cfg}->{DRIVER} }, ( DBH => $self->dbh );
# $self->authz->config( $cfg->{authz_cfg} );
my $_self = $self; weaken $_self; # or get circular ref inside authz config()
# only used for package-wide auth ie __PACKAGE__->authz->authz_runmodes()
$self->authz->config(
DRIVER => [ 'Generic', sub {
# Generic driver recieves username as 1st arg (don't need it here):
my ($username, $action) = @_; # warn $action;
return $_self->user_can($action); # using user_can() to validate
}
],
# FORBIDDEN_RUNMODE => 'forbidden', # doesn't work with CA::Dispatch for
# class-wide authz, so defining authz_forbidden rm in prerun() instead
);
#-------------------------------------------------------------------------------
# CAP::Flash config: using CAP::MessageStack & self->flash() as drop-in replacement
# my $flash_config = $cfg->{flash};
# $self->flash_config( @$flash_config ); # using CGI::Session::Flash & $self->flash
#-------------------------------------------------------------------------------
# CAP::LogDispatch config (needs to be after session & authen configs):
# $self->_cap_logdispatch_setup; # comment out if using LIMS::Local::LogDispatch instead
#-------------------------------------------------------------------------------
# experimental - to stop large build-up of 'form_state_cap_form_state_<32-digits>
# => 172800' in session table (but still in _SESSION_EXPIRE_LIST from CGI::Session)
# TODO: actually dangerous if params expire - all will be null so params updated as such
# $self->form_state->config( expires => '+30m'); # puts form_state into url
}
#-------------------------------------------------------------------------------
# add CGI_SESSION_OPTIONS (cgi method, session driver, etc) to session_config():
sub _set_cgisession_options {
my $self = shift;
my $cgi = $self->query;
my $cfg = $self->cfg;
# override $cfg->{settings}->{db_session_serializer} to a readable format
# if running test suite:
$cfg->{settings}->{db_session_serializer} = 'default' if $ENV{HARNESS_ACTIVE};
my %h = (
db => [
'driver:MySQL;serializer:'.$cfg->{settings}->{db_session_serializer},
$cgi, { Handle => $self->dbh },
],
# need IDFile, IDInit & IDIncr in session_options_file if using id:incr
file => [
'driver:File;serializer:'.$cfg->{settings}->{file_session_serializer},
$cgi, $cfg->{session_options_file},
],
);
# select CGI_SESSION_OPTIONS driver method (db or file):
my $use_file_sessions = # use file for sessions if:
$ENV{USE_FILE_SESSIONS} # set in L::Local::LIMS
|| $cgi->param('USE_FILE_SESSIONS') # if called via chart via cron
|| ( $ENV{SERVER_SOFTWARE} =~ /HTTP::Server::Simple/
&& ! $ENV{USE_DB_SESSIONS} ); # command-line flag
my $driver = $use_file_sessions ? 'file' : 'db';
return $h{$driver};
}
#-------------------------------------------------------------------------------
sub _authen_config { # doesn't work in lims_config.pl using L::L::C::instance()
my $self = shift;
my $_self = $self; weaken($_self); # or get circular ref inside callback
my $authen_driver
= $ENV{ROSEDB_DEVINIT} =~ /devinit_devel/ && ! $ENV{DB_SESSIONS}
? 'Dummy' # ! $ENV{HARNESS_ACTIVE} # use 'Dummy' login for devel
: [ # generic driver passes authen_username & authen_password:
'Generic', sub {
my ($u, $p) = @_; my $v = $_self->query->Vars(); # warn Dumper $v;
$_self->model('User')->verify_credentials($u, $p, $v);
}
]; # warn Dumper $authen_driver;
# custom method to fine-tune timeout based on user type:
my $authen_timeout = sub { # returns true if the session should be timed out
my $authen = shift;
my $max_idle = $_self->user_profile->{session_idle_timeout}; # warn $max_idle;
# _debug_authen($authen->last_access, $max_idle);
my $is_timed_out = ( time() - $authen->last_access > $max_idle ); # warn $is_timed_out;
return $is_timed_out; # returns truth
};
return {
DRIVER => $authen_driver,
LOGIN_SESSION_TIMEOUT => {
IDLE_FOR => '24h', # same as session default - overridden under CUSTOM:
EVERY => '1d',
CUSTOM => \&$authen_timeout, # true if the session should be timed out
},
LOGIN_RUNMODE => 'login', # redirect_after_login requires destination field in .tt if used
STORE => 'Session', # ie CAP::Store::Session
}; # warn Dumper $cfg->{authen_cfg};
}
#-------------------------------------------------------------------------------
sub _configure_protected_runmodes { # CAP::Authentication protected_runmodes:
my $self = shift;
# all rm's protected except forgotten password, logout & AJAX functions:
# (need 'logout' or will have to login an expired session 1st to logout!!)
my $unprotected_runmodes = join '|', qw( password_ logout patient_access );
my @unprotected_classes = qw(ajax chart); # whole classes # eg from cron script
my $loaded_class = $self->param('Class'); # set in LIMS::Dispatch
# exempt @unprotected_classes from being defined as protected_runmodes:
unless ( $loaded_class && grep lc $loaded_class eq $_, @unprotected_classes ) {
$self->authen->protected_runmodes( qr/^(?!$unprotected_runmodes)/ );
} # warn Dumper [$loaded_class, $self->authen->protected_runmodes];
}
#-------------------------------------------------------------------------------
sub _debug_authen { # called from within closure so don't use $self
my ($last_access, $timeout) = @_;
my $msg = sprintf 'LOGIN_SESSION_TIMEOUT: idle=%s, timeout=%s',
time() - $last_access, $timeout;
LIMS::Local::Debug::DEBUG($msg); # can't use $self->debug() - see above
}
#-------------------------------------------------------------------------------
sub _log_process_size { # log query string, pid & process size
my $self = shift;
# return unless $ENV{FAST_CGI};
my $logfile = "$FindBin::Bin/../logs/process-size.txt";
my $query = $self->query->self_url();
$query =~ s/(authen_password=).*/$1/; # don't log passwds
my $content = sprintf "[%s:%s] %s %s\n", $$,
LIMS::Local::Utils::format_number(`ps -p $$ -o size=`+0),
LIMS::Local::Utils::date_and_time_now, $query; # warn $content;
io($logfile)->append($content);
#=begin
my %diffs;
my $arena_ref_counts = arena_ref_counts();
my $arena_ref_counts_pre = $self->arena_ref_counts();
foreach (keys %$arena_ref_counts_pre) {
$diffs{$_} = [$arena_ref_counts_pre->{$_}, $arena_ref_counts->{$_}]
if $arena_ref_counts_pre->{$_} != $arena_ref_counts->{$_};
}
io($logfile)->append(Dumper \%diffs);
#=cut
io($logfile)->append(arena_table());
io($logfile)->append('=' x 80 . "\n");
return arena_table();
}
#-------------------------------------------------------------------------------
=begin # home page replaced with single-click login form now
sub _check_portal_referral {
my $self = shift; # $self->stash( REMOTE_ADDR => $ENV{REMOTE_ADDR} ); # to check mod_rpaf is working
# if user not logged in, have neither profile nor authen->username; on 1st login
# have authen->username but no profile (it's created after return from here); if
# logged in but timed-out, have profile but not authen->username. So need to
# check for profile OR username OR valid 'access_token' form flag OR permitted
# direct-entry IP address. Also allow :8080 VPN access on non-approved IP addr
my $user_profile = $self->user_profile; # warn Dumper $user_profile;
my $settings = $self->cfg('settings');
my $portal_access_ok = 0; # '/' sends access token as SHA1 digest of today DT
if ( my $token = $self->query->param('access_token') ) {
my $str = LIMS::Local::Utils::today->datetime; # eg 2010-01-01T00:00:00
$portal_access_ok = ( $token eq LIMS::Local::Utils::sha1_digest($str) );
}
return 1 # return OK if already logged in or hidden form param supplied:
if $self->authen->username # ie logged in and not timed out (see above)
|| $user_profile # ie AFTER initial login, even if timed-out (see above)
|| $settings->{is_test_platform} # global.txt (for test server)
|| $portal_access_ok # from login page originally via portal root '/'
|| $ENV{SERVER_PORT} == 8080; # for VPN access on non-approved IP addr
# get array(ref) of permitted direct-entry IP addresses:
my $permitted = $self->get_yaml_file('local_addr'); # $self->debug($cfg);
# will return true only if REMOTE_ADDR matches a permitted ip address:
return ( grep { $ENV{REMOTE_ADDR} =~ /^$_/ } @$permitted );
}
=cut
#-------------------------------------------------------------------------------
sub _set_active_link { # for colourising tabs in tt display
my $self = shift; # use Data::Dumper; # warn Dumper $self->query->path_info;
my $default = 'search'; # default link
# get 'class' arg (if exists) from url eg /foo/bar/1 - class = 'foo':
my $class = ( split '/', $self->query->path_info )[1] || return $default;
# for classes that don't correspond directly to nav links:
my $mapped = {
# class nav-link
patient => 'register',
# request => 'register', # TODO: matches also 'unlock' & 'email_record'
config => 'admin',
};
my $active_link = $mapped->{$class} || $class || $default;
$self->tt_params( active_link => $active_link ); # warn $active_link;
}
#-------------------------------------------------------------------------------
sub _dump_authen_params {
my $self = shift;
my $profile = $self->user_profile; # warn Dumper $profile;
my $authen = $self->authen; # warn $authen->username;
no warnings 'uninitialized';
$self->debug([
'redirect_after_login:' . $authen->redirect_after_login || 0,
'is_authenticated:' . $authen->is_authenticated || 0,
'is_login_timeout:' . $authen->is_login_timeout || 0,
'profile_username:' . $profile->{username} || '',
'is_new_login:' . $authen->is_new_login || 0,
'last_access:' . $authen->last_access || '',
'last_login:' . $authen->last_login || '',
'username:' . $authen->username || '',
]);
}
#-------------------------------------------------------------------------------
# called from cgiapp_prerun only if authen->username exists && profile doesn't:
sub _create_user_profile {
my $self = shift;
my $settings = $self->cfg('settings');
# get users' details from users table, or die (can't use error() as session
# doesn't exist yet, so user_can() call from tmpl fails):
my $username = $self->authen->username;
my $user_details = $self->model('User')->get_user_by_username($username)
|| die 'no user details found in _create_user_profile()';
# first look for custom permissions:
my $user_permissions = # arrayref
$self->model('User')->get_user_permissions($user_details->id);
# if no custom permissions, load default settings for this users' group:
if (! @$user_permissions) {
$user_permissions =
$self->model('User')->get_user_group_functions($user_details->group_id);
}
# user_profile object to hashref - don't force_load or dies on login table
my $profile = $user_details->as_tree; # $self->debug($profile);
$profile->{user_location}->{centre} = $settings->{_centre};
# get list of function_names from user_permissions object:
my @functions = map { $_->function->function_name } @$user_permissions;
$profile->{functions} = \@functions; # $self->debug($profile);
{ # does user belong to local network?
my $belongs_to_local_network
= $self->model('User')->in_local_network($profile->{user_location_id});
$profile->{is_local_network} = $belongs_to_local_network;
}
{ # session idle-timeout:
my $user_location = $profile->{user_location}->{location_name};
my $overrides = $self->get_yaml_file('idle_timeout') || {};
my $timeout = ( grep $_ eq 'do_admin', @functions ) # has admin function
? $settings->{admin_timeout} # value set in 'EVERY' will still apply
: $overrides->{$user_location} || $settings->{default_user_timeout};
$profile->{session_idle_timeout} = $timeout; # warn $timeout;
}
# set session & authen user profile:
$self->session->param( UserProfile => $profile ); # TODO (lot of work) can probably replace this with:
$self->authen->store->save(yooza_profile => $profile); # for CAP::Authen LOGIN_SESSION_TIMEOUT
# skip following functions if dev_server:
return if $ENV{DEVEL_SERVER};
# update last_login date on user table:
$self->model('User')->update_last_login($username);
# register successful login (except db admin):
unless ( $profile->{designation} eq 'administrator' ) { # || ! $ENV{MOD_PERL};
$self->model('User')->register_login($self->session);
}
}
# ?? only works if rm = requested, not forwarded (use LIMS::get_template_name for that)
sub _tmpl_name_generator {
return sub {
my $self = shift;
# my $self->tt_template_name(1); # causes infinate loop -> out-of-memory error
my $rm = $self->get_current_runmode; # warn $rm;
my $module = ref $self; # warn $module;
# remove LIMS & LIMS/Controller from $module:
my @segments = grep $_ !~ 'LIMS|Controller', split '::', $module;
my $catfile = File::Spec->catfile(@segments, $rm);
my $tmpl = lc $catfile . '.tt';
# $self->debug('auto-generated template: ' . $tmpl);
return $tmpl;
};
}
#-------------------------------------------------------------------------------
sub _offline_mode {
my $self = shift; $self->_limerick;
return $self->tt_process('site/maintenance.tt');
}
#-------------------------------------------------------------------------------
sub _limerick {
my $self = shift;
my $src_file = $self->cfg('path_to_app_root') . '/src/lib/lear.txt';
return 0 unless (-e $src_file);
require LIMS::Local::Stuff; # to avoid compile-time error if absent
{ # limerick:
my $data = LIMS::Local::Stuff::limerick($src_file);
$self->tt_params(limerick => $data);
}
{ # MOTD:
my $data = LIMS::Local::Stuff::motd(); # just 1 sentence
$self->tt_params(motd => $data);
}
# set flag for tt to enable/disable:
$self->tt_params( devel_server => $ENV{DEVEL_SERVER} );
}
#-------------------------------------------------------------------------------
sub _debug_path {
my ($self, $method) = @_;
if (! $method) {
my @caller = caller(1); # warn $caller[3];
($method) = $caller[3] =~ /.*::(.*)/; # greedy matching ensures last
}
# done in LOG_DISPATCH_OPTIONS callbacks sub now:
# my $timings =
# sprintf "%s, %.4f sec", $method, tv_interval $self->param('t0'), [gettimeofday];
$self->debug($method); # DEBUG( $timings );
}
#-------------------------------------------------------------------------------
# never gets called if using CA::Dispatch - CAD uses its own error handling for
# non-existent rms
sub _exception {
my ($self, $intended_runmode) = @_; # $obj->_dump_path('_exception');
# my $output = "Looking for '$intended_runmode', but found 'AUTOLOAD' instead";
$self->tt_params(
mode => 'Error', # title
msg => $intended_runmode,
title => 'Unknown Action',
);
return $self->tt_process('site/exception.tt');
}
sub _capture_weakself {
# use as: my $callback = $self->_capture_weakself(sub { my ($self, @args) = @_ });
my ($self, $code) = @_;
weaken(my $weak_self = $self);
return sub {
$code->($weak_self, @_)
}
}
1;
__END__
# uses CAP::TT tt_template_name method to return path to template
# alternative to TEMPLATE_NAME_GENERATOR in tt_config - should be able to handle
# forwarded rm's; requires tmpl name to match module path
# (eg Admin::Screen::default() => admin/screen/default.tt):
=begin
sub _get_template_name {
my $self = shift;
# eg LIMS/Admin/Screen/Test/default.tmpl
my @segments = grep $_ !~ 'LIMS|Controller', split '/', $self->tt_template_name(1);
my $tmpl = File::Spec->catfile(@segments);
$tmpl =~ s/tmpl/tt/; # using tt suffix
return lc $tmpl; # DEBUG 'auto-generated template: ' . $tmpl;
}
=cut
# returns dbh object (and sets authen_cfg driver - not any more):
=begin # replaced with own dbh() method now
sub _dbh_config {
my $self = shift;
# Rose::DB method:
# my $driver = 'dbi_driver'; # not using now, replaced with Generic & sub {}
return LIMS::DB->new_or_cached->retain_dbh; # need retain_dbh or get:
=begin
ERROR' for request '/hmds/admin/user_location': Error executing class callback
in init stage: Can't connect to data source
'LIMS::DB::__RoseDBPrivate__::Rose::DB::MySQL=HASH(0x9a810f4)' because I can't
work out what driver to use (it doesn't seem to contain a 'dbi:driver:' prefix
and the DBI_DRIVER env var is not set) at
/home/raj/perl5/lib/perl5/CGI/Application/Plugin/DBH.pm line 42
=cut
# $dbi->trace(1, './logs/trace.log'); # best switched on in LIMS::DB::dbi_connect
# switch on profiling:
#use DBI::Profile;
#$dbi->{Profile} = DBI::Profile->new();
#$dbi->{Profile} = 2;
=begin # DBIC method:
use lib '/home/raj/www/apps/LIMS/tags/legacy/lib';
use LIMS::Schema;
$self->dbh_config( $cfg->{'dbh_params'} );
# add schema to object - move to own class - load as needed:
$self->param( schema => LIMS::Schema->connect(@{ $cfg->{dbh_params} }) );
$cfg->{'dbic_driver'}->[2] = $self->param('schema'); # SCHEMA
my $driver = 'dbic_driver';
=cut
=begin # using DRIVER = "Generic, sub {}" now - set in _configure_plugins()
# override DBH => undef in $self->cfg->{dbi_driver}:
@{ $self->cfg->{dbi_driver} }[2] = $db;
$self->cfg->{authen_cfg}{DRIVER} = $self->cfg->{$driver};
=cut
# return $db; # moved to top
#}
=begin # doesn't work with LIMS::Local::Config->instance method
sub _cap_logdispatch_setup { # using LIMS::Local::LogDispatch instead
my $self = shift;
my $cfg = $self->cfg; # warn Dumper $cfg;
# can't have $self in a callback:
my $t0 = $self->param('t0');
my $user = $self->authen->username;
$cfg->{log_dispatch}{LOG_DISPATCH_OPTIONS} = {
callbacks => sub {
my %h = @_; chomp $h{message};
my $timestamp = strftime "[%d-%b-%Y %H:%M:%S]", localtime;
return sprintf "%s %s %s [%.4f sec]\n",
$timestamp,
uc $user,
$h{message},
tv_interval $t0, [gettimeofday];
},
}; # warn Dumper $cfg->{log_dispatch};
$self->log_config( $cfg->{log_dispatch} );
}
=cut
