#!/usr/bin/env perl
#-------------------------------------------------------------------------------
# request-for-change web form
# query params contain encrypted username & centre in initial request from HILIS:
# script/cgi/rfc.cgi?u=53616c7465645f5ff9[...]&c=53616c7465645f5f[...]
#-------------------------------------------------------------------------------
package RequestForChange;
use lib '/home/raj/perl5/lib/perl5';
use Web::Simple; # imports strict & warnings so don't repeat or it breaks
use IO::All;
use Template;
use Path::Tiny;
use Data::Dumper;
use HTML::FillInForm;
use Data::FormValidator;
use Data::FormValidator::Constraints qw(:closures);
# use CGI::Carp qw(fatalsToBrowser); # use for devel
use CGI::HTMLError (trace => 1); # use in production
use FindBin qw($RealBin); # warn $RealBin;
use lib $RealBin . '/../../lib';
use lib $RealBin . '/../prereq_lib'; # make sure we are using old HTTP::Tiny
use HTTP::Tiny;
# die "HTTP::Tiny version error: $HTTP::Tiny::VERSION" if $HTTP::Tiny::VERSION > '0.012';
use LIMS::Local::Config;
use LIMS::Model::Email;
use LIMS::Local::Utils;
use LIMS::Local::ScriptHelpers;
use LIMS::Local::IssueTracker;
my $config = LIMS::Local::Config->instance;
my $tools = LIMS::Local::ScriptHelpers->new;
my $dbix = $tools->dbix;
my $SERVICE = $config->{settings}->{service_email};
my $ADMIN = $config->{settings}->{admin_contact};
my $debug = path($RealBin, 'debug.txt')->realpath;
io($debug)->print(); # reset
# template src:
use constant TMPL_DIR => path($RealBin, '..', '..', 'templates')->realpath;
use constant TMPL => 'user/rfc.tt';
my $today = LIMS::Local::Utils::today; # datetime object
my $NOW = 'NOW()'; # mysql function
sub dispatch_request {
# just return empty form to fill in:
sub (GET + ?:u=&:c=) { # collect query params 'u' & 'c' as hashref
my ($self, $ref) = @_; # _debug($ref);
[ 200, [ 'Content-type', 'text/html' ], [ $self->render_view($ref) ] ]
},
sub (POST + %*) { # collect all body params as hashref
my ($self, $params) = @_; # _debug($params);
[ 200, [ 'Content-type', 'text/html' ], [ $self->process($params) ] ]
},
sub () { # something else submitted:
[ 405, [ 'Content-type', 'text/plain' ], [ 'Method not recognised' ] ]
}
}
# if submitted form:
sub process {
my ($self, $vars) = @_; # _debug($vars);
my $dfv = _dfv();
my $dfv_profile = _dfv_profile(); # DEBUG($dfv_profile);
my $results = $dfv->check($vars, $dfv_profile); # DEBUG($results);
if ( $results->has_invalid or $results->has_missing ) { # DEBUG($results);
$vars->{errs} = $results->msgs;
}
else { # no validation errors:
my $rtn = $self->send_application($vars);
if ($rtn) { # sendmail error:
$vars->{msg} = $rtn;
}
else { # messages sent OK:
$vars->{send_success} = 1;
}
}
return $self->render_view($vars);
}
sub render_view {
my ($self, $vars) = @_; # _debug($vars);
my $key = $today->ymd; # so url only valid on same day
# u contains encrypted username in initial request from HILIS:
if ( my $tkn = $vars->{u} ) { # _debug($tkn);
my $username = LIMS::Local::Utils::decrypt($tkn, $key);
$vars->{username} = $username;
}
# c contains encrypted centre in initial request from HILIS:
if ( my $tkn = $vars->{c} ) { # _debug($tkn);
my $centre = LIMS::Local::Utils::decrypt($tkn, $key);
# save var as 'app_name' NOT centre to avoid confusion with settings._centre
$vars->{app_name} = $centre; # for use in email lookup
} # _debug($vars);
# add settings to $vars:
$vars->{settings} = $config->{settings}; # _debug($vars);
# get TT object:
my $t = Template->new({ INCLUDE_PATH => TMPL_DIR });
my $template_output;
$t->process(TMPL, $vars, \$template_output)
|| die "Template process failed: ", $t->error(), "\n";
my $output = HTML::FillInForm->fill( \$template_output, $vars );
return $output;
}
sub send_application {
my ($self, $vars) = @_; # _debug($vars);
my $username = $vars->{username};
my @recipients = ($ADMIN); # $vars->{email}
# add service email if different to admin address:
push @recipients, $SERVICE if $SERVICE ne $ADMIN;
# maybe change database?
unless ( $vars->{app_name} eq 'leeds' ) { # _debug($vars->{db_name});
$dbix->dbh->do('USE ' . $vars->{app_name});
}
my $user = $dbix->select('users', ['id', 'email'],
{ username => $username })->hash;
if ( my $cc = $user->{email} ) {
push @recipients, $cc;
}
else {
warn "no email address for $username";
}
my %db_data = (
details => $vars->{details},
reason => $vars->{reason},
status => $vars->{status},
user_id => $user->{id},
created => \$NOW,
);
# not sure if mysql_insertid will lead to race condition but not a real problem given scale
$dbix->insert('rfc', \%db_data ); # need to get id back
my $rfc_id = $vars->{rfc_id} = $dbix->dbh->{mysql_insertid};
my $service_suffix = $config->{settings}->{lab_number_prefix};
my $message_body = _message_body($vars);
my $subject = sprintf 'HILIS RfC%s%s [%s]',
$rfc_id, $service_suffix, uc $username;
my %mail = (
config => $config->{settings},
message => $message_body,
subject => $subject,
); # _debug(\%mail); return 0; # 'some reason for mail failure';
for my $addr (@recipients) {
$mail{recipient} = $addr; # DEBUG(\%mail);
my $rtn = LIMS::Model::Email->send_message(\%mail); # returns Return::Value object
return $rtn->string if $rtn->type ne 'success';
}
# create new issue in issue tracker
eval {
my $t = LIMS::Local::IssueTracker->new;
my $res = $t->create_rfc(
{ name => $subject, desc => $message_body, reason => $vars->{reason} } )
or die "couldn't add issue in issue tracker: $!";
$dbix->update('rfc', {remote_id => $res}, {id => $rfc_id } );
};
warn $@ if $@; # log failure in apache logs
return 0; # messages sent OK
}
sub _dfv_profile {
return {
required => [ qw(username centre reason details status) ],
}
}
sub _message_body {
my $vars = shift;
my $content = sprintf "Date: %s\nUsername: %s [%s]\nRFC ID: %s\n"
. "Reason: %s\nStatus: %s\n\nDetails: %s\n",
$today->dmy, uc $vars->{username},
@{$vars}{ qw(centre rfc_id reason status details) };
return $content;
}
sub _dfv {
my $defaults = $config->{dfv_defaults}; # DEBUG($defaults);
my $dfv = Data::FormValidator->new({}, $defaults);
return $dfv;
}
sub _debug {
my $obj = shift;
io($debug)->append(Dumper $obj);
}
RequestForChange->run_if_script;
