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::Controller::Roles::DataMap',
);
#use strict;
#use warnings;
#use base 'LIMS::Titanium'; # std CPAN Titanium with some additional modules loaded
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 POSIX qw(strftime); # only required by CAP::LogDispatch callback
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;
}
# set Time::HiRes base-line; needs to be before Log::Dispatch setup
$self->param( t0 => [gettimeofday] );
# CAP::DBI - load dbh into object - replaced with own dbh() method now
# my $dbi = $self->_dbh_config; $self->dbh_config( $dbi );
# configure plugins:
$self->_configure_plugins;
# everything protected except forgotten password, logout & AJAX functions:
# (need 'logout' or will have to login an expired session 1st to logout!!)
$self->authen->protected_runmodes( qr/^(?!password_|logout|do_ajax)/ );
$self->debug($self->query); # needs to be done after plugin config
#require LIMS::Local::DevelCycle; # warn Devel::Cycle::find_cycle($self);
#my $out = LIMS::Local::DevelCycle::find($self); warn $out if $out;
}
#-------------------------------------------------------------------------------
sub setup {
my $self = shift;
$self->run_modes(
login => 'login',
AUTOLOAD => \&_exception,
); # warn Dumper $self->run_modes;
}
#-------------------------------------------------------------------------------
sub cgiapp_prerun {
my $self = shift;
# check access route is permitted (ie direct or via portal):
return $self->redirect('/') unless $self->_check_portal_referral();
$self->tt_params(
app_url => $self->query->url,
url_with_path => $self->query->url(-path_info=>1), # also works in template c.query.utl(path_info=1);
# VERSION => $VERSION, # doesn't work under production env
# action => (split '/', $self->query->path_info)[1], # using c.query.path_info.match('^/' _ link) instead
);
$self->_create_user_profile() if
$self->authen->username &&
! defined $self->session->param('UserProfile');
# $self->debug($self->session->dump);
# re-direct to new/relapsed diagnosis list if flag set in _create_user_profile():
if ( my $org_code = $self->{stash}->{_user_location_org_code} ) {
my $url = '/resources/new_diagnoses?org_code=' . $org_code;
return $self->redirect( $self->query->url . $url );
}
# pass username to QueryLog for sql logging:
LIMS::Local::QueryLog::set_querylog_args({user => $self->authen->username});
# pass config args to errorhandler (needs admin email, smtp, etc):
LIMS::Local::ErrorHandler::set_errorhandler_args({
cfg => $self->cfg('settings'),
user => $self->authen->username,
});
# otherwise CAD-loaded classes can't find it for package-wide authorization:
$self->run_modes( authz_forbidden => 'forbidden' );
$self->_set_active_link();
# alternative to $self->authen->protected_runmodes:
# $self->authen->username ?
# $self->authen->redirect_after_login :
# $self->authen->redirect_to_login;
}
#-------------------------------------------------------------------------------
sub cgiapp_postrun { }
#-------------------------------------------------------------------------------
sub teardown {
my $self = shift;
$self->session->flush; # recommended action
}
#-------------------------------------------------------------------------------
# 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()
#-------------------------------------------------------------------------------
# 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(@_) }
#-------------------------------------------------------------------------------
# RUNMODES
#-------------------------------------------------------------------------------
sub login {
my $self = shift;
# for destination in login.tt - query->self_url with query_string args removed:
$self->tt_params( destination_url => $self->query->url(-path_info=>1) );
$self->_limerick();
return $self->tt_process('site/login.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:
$cfg->{authen_cfg}->{DRIVER} = # override $cfg->{authen_cfg}->{DRIVER} = []
$ENV{ROSEDB_DEVINIT} =~ /devinit_devel/ # use 'Dummy' login for devel
? 'Dummy' # ! $ENV{HARNESS_ACTIVE}
: [ 'Generic', sub { $self->model('User')->verify_credentials(@_) } ];
$self->authen->config( $cfg->{authen_cfg} ); # $self->debug($cfg->{authen_cfg});
#-------------------------------------------------------------------------------
# ValidateRM/DFV config:
$self->param( dfv_defaults => $cfg->{dfv_defaults} );
#-------------------------------------------------------------------------------
# CAP::MessageStack config:
$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 $obj = $self; weaken $obj; # or we 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 $obj->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 $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 %CGI_SESSION_OPTIONS = (
db => [
'driver:MySQL;serializer:'.$cfg->{settings}->{db_session_serializer},
$self->query,
{ Handle => $self->dbh },
],
# need IDFile, IDInit & IDIncr in session_options_file if using id:incr
file => [
'driver:File;serializer:'.$cfg->{settings}->{file_session_serializer},
$self->query,
$cfg->{session_options_file},
],
);
# select CGI_SESSION_OPTIONS driver method from settings.txt (db or file):
my $session_driver # sessions dir if lims_server.pl
= $ENV{SERVER_SOFTWARE} =~ /HTTP::Server::Simple/ ?
$cfg->{settings}->{session_driver} :
'db'; # sessions table for production or test harness
return $CGI_SESSION_OPTIONS{$session_driver};
}
#-------------------------------------------------------------------------------
sub _check_portal_referral {
my $self = shift; # $self->stash( REMOTE_ADDR => $ENV{REMOTE_ADDR} ); # to check mod_rpaf is working
return 1 # return OK if already logged in or hidden form param supplied:
if $self->authen->username || $self->query->param('is_portal_access')
|| $ENV{SERVER_PORT} == 8080; # 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 );
}
#-------------------------------------------------------------------------------
sub _set_active_link {
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;
}
#-------------------------------------------------------------------------------
=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
#-------------------------------------------------------------------------------
# called from cgiapp_prerun only if authen->username exists && profile doesn't:
sub _create_user_profile {
my $self = shift;
my %args = (
col => 'username',
value => $self->authen->username,
);
# 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 $user_details = $self->model('User')->get_user_details(\%args)
|| 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);
}
# get list of function_names from user_permissions object:
my @functions = map { $_->function->function_name } @$user_permissions;
# user_profile object to hashref - don't force_load or dies on login table
my $profile = $user_details->as_tree; # $self->debug($profile);
# stuff functions list into $profile:
$profile->{functions} = \@functions; # $self->debug($profile);
# set session UserProfile:
$self->session->param( UserProfile => $profile ); # TODO - can probably replace this with:
$self->authen->store->save(yooza_profile => $profile); # for CAP::Authen LOGIN_SESSION_TIMEOUT
{ # update userid col of sessions table:
my $args = {
session_id => $self->session->id,
userid => $self->authen->username,
};
$self->model('User')->update_session_userid($args); # also updates last_login
}
return if $profile->{designation} eq 'administrator'; # || ! $ENV{MOD_PERL};
# register successful login (except db admin):
$self->model('User')->register_login($self->session);
{ # if users location exists in email_contacts.display_name col, set flag for re-direct:
my $user_location_id = $profile->{user_location_id};
my $o = $self->model('User')->get_user_location($user_location_id);
my $location = $o->location_name;
my $user_locations_map = $self->user_locations_map; # from email_contacts tbl
$self->{stash}->{_user_location_org_code} = $user_locations_map->{$location};
}
}
# ?? 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 _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::Drollness; # to avoid compile-time error if absent
my $data = LIMS::Local::Drollness::limerick($src_file);
$self->tt_params( limerick => $data );
}
#-------------------------------------------------------------------------------
# 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
#}
#-------------------------------------------------------------------------------
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');
}
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
