• Files
• Commits
• Log
• Graph
• Stats

#!/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 LIMS::Local::Config;
use LIMS::Model::Email;
use LIMS::Local::Utils;
use LIMS::Local::ScriptHelpers;

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;

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 $message_body;
    my $username     = uc $vars->{username};
    my $subject;

    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});
    }
    $dbix->query('select id from users where username = ?', $username)->into(my ($user_id));
    my %db_data = (
        reason  => $vars->{reason},
        details => $vars->{details},
        status  => $vars->{status},
        user_id => $user_id
    );
# not sure if mysql_insertid will lead to race condition but not a real problem given scale
    $dbix->insert('rfcs', \%db_data ); # need to get id back
    my $table_key = $dbix->dbh->{'mysql_insertid'};
    $dbix->select('users', 'email', { username => $username } )->into(my $cc);
    if ($cc) {
        push @recipients, $cc;
    }
    else {
        warn "no email address for $username";
    }

    $vars->{rfc_id} = $table_key;
    $message_body = _message_body($vars);
    $subject      = "HILIS RfC-$table_key [$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';
    }
    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\nReason:   %s\nStatus:   %s\n\n"
    . "Details:  %s\n", $today->dmy, uc $vars->{username},
        map $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;