#!/usr/bin/env perl
#===============================================================================
#
# DESCRIPTION:
#
# RFC.cgi uses different database for each centre but the same Trello board. Need to use database as source and then query Trello for updates. The it wont get confused about cards from different centres.
# cron can run foreach my $centre @centres
# set database to use # access Trello
# features
# updates status of records
# reinstates deleted records
# emails user when complete or rejected (live only)
# ?generates report of all completed RfCs between date range
#
#===============================================================================
package LIMS::Local::RfC;
our $VERSION = "0.01";
use Modern::Perl;
use utf8;
use Moose;
use namespace::autoclean;
use DDP;
use Try::Tiny;
use LIMS::Local::ScriptHelpers;
use LIMS::Local::IssueTracker;
use LIMS::Local::Utils;
use LIMS::Model::Email;
use FindBin qw($RealBin);
my $config = LIMS::Local::Config->instance;
my $tools = LIMS::Local::ScriptHelpers->new;
my $today = LIMS::Local::Utils::today; # datetime object
has 'centre' => (
is => 'ro',
isa => 'Str',
default => "leeds",
);
has 'tracker' => (
is => 'ro',
isa => 'LIMS::Local::IssueTracker',
default => sub {
LIMS::Local::IssueTracker->new( config_file =>
"$RealBin/../config/settings/.leeds/issue_tracking.yml" );
},
);
has 'database' => (
is => 'ro',
isa => 'DBIx::Simple',
default => sub { $tools->dbix },
);
with 'LIMS::Local::Role::NotTestable' => { unsafe => [qw/_send_acknowledgement/] };
# all rfc cardIDs that are neither complete or rejected
# param optional date range?
sub find_incomplete_rfcs {
my $self = shift;
my @results = $self->database->query( <<'EOS')->hashes;
SELECT r.id, username, reason, details, email, status, created, remote_id
FROM
rfc r
JOIN
users u ON r . user_id = u . id
WHERE
status NOT IN( 'complete', 'rejected' )
AND remote_id IS NOT NULL
EOS
return @results;
}
# takes list of RfCs and updates their status in database
sub update_rfcs {
my ( $self, @list ) = @_;
#say "@list";return;
foreach my $rfc (@list) {
my $status = $self->tracker->get_status_config_name( $rfc->{remote_id} );
next unless $status =~ /complete|rejected/; # only update if finished
$self->database->update(
'rfc',
{ status => $status },
{ id => $rfc->{id} }
) or die "couldn't update rfc table: $!";
$self->_send_acknowledgement();
}
return 1;
}
# returns list of incomplete RfCs that are not on Trello
sub find_orphans {
my $self = shift;
my @results = $self->database->query( <<'EOS')->hashes;
SELECT r.id, username, reason, details, email, status, created
FROM
rfc r
JOIN
users u ON r . user_id = u . id
WHERE
status NOT IN( 'complete', 'rejected' )
AND remote_id IS NULL
EOS
return @results;
}
sub get_rfc {
my $self = shift;
my $id = shift;
my $result = $self->database->query( <<'EOS', $id )->hash;
SELECT r.id, username, reason, details, email, status, created
FROM
rfc r
JOIN
users u ON r.user_id = u.id
WHERE
r.id = ?
EOS
return $result;
}
# relist on trello incase it is deleted. Tries to recover from archive first
sub recreate_issue {
my $self = shift;
my $rfc;
if ( ref $_[0] eq 'HASH' ) { # defined
$rfc = shift;
}
else {
my $id = shift;
$rfc = $self->get_rfc($id);
}
my $not_found = 0;
try {
# does it exist bubble up
$self->tracker->get_status( $rfc->{remote_id} );
# if so, unarchive it so we can see it
$self->tracker->unarchive_card( $rfc->{remote_id} );
}
catch {
my $cardID = $self->tracker->create_issue(
{
name => $self->_rfc_string($rfc),
desc => $self->_message_body($rfc),
reason => $rfc->{reason}
}
);
$self->database->update(
'rfc',
{ remote_id => $cardID },
{ id => $rfc->{id} }
) or die "couldn't update rfc table: $!";
};
return 1;
# TODO better look in archive first so we dont loose any comments
}
# future
# read comments on possibly archived card to review its history
sub review_issue {
my $self = shift;
}
sub _send_acknowledgement {
my $self = shift;
my $mail = shift;
say "LIVE CODE";
# TODO
# my $rtn =
# LIMS::Model::Email->send_message($mail); # returns Return::Value object
# return $rtn->string if $rtn->type ne 'success';
}
sub _testing_send_acknowledgement {
my $self = shift;
say "TEST CODE";
say "No mail sent";
}
sub _rfc_string {
my $self = shift;
my $rfc = shift;
my $service_suffix = uc substr( $self->centre, 0, 1 );
my $subject = sprintf 'HILIS RfC%s%s [%s]',
$rfc->{id}, $service_suffix, uc $rfc->{username};
return $subject;
}
sub _message_body {
my $self = shift;
my $vars = shift;
my $date = $vars->{created} // $today->dmy;
my $content = sprintf "Date: %s\nUsername: %s [%s]\nRFC ID: %s\n"
. "Reason: %s\nStatus: %s\n\nDetails: %s\n",
$date, uc $vars->{username},
$self->centre, @{$vars}{qw(id reason status details)};
return $content;
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=head1 NAME
LIMS::Local::RfC
=head1 VERSION
This documentation refers to LIMS::Local::RfC version 0.01
=head1 SYNOPSIS
use LIMS::Local::RfC;
my $rfc = LIMS::Local::RfC->new( database => $dbix );
$rfc->find_incomplete_rfcs;
my @orphans = $rfc->find_orphans;
$rfc->recreate_issue($_) for @orphans;
=head1 DESCRIPTION
Interface between database and issuetracker to manage RfC issues
=head1 DIAGNOSTICS
=over 2
=item find_orphans()
get all RfCs from database without a remote_id (no tracker info)
return ARRAY of HashRefs
=item find_incomplete_rfcs()
get all RfCs from database who's status is neither complete nor rejected
return ARRAY of HashRefs
=item get_rfc("id")
Get database record of rfc
return HashRef
=item recreate_issue(HashRef)
creates a new issue in tracker from database record
returns True
=item update_rfcs(HashRef,HashRef,...)
updates status (list name) from tracker to database
returns True
=back
=head1 CONFIGURATION AND ENVIRONMENT
Issuetracker configuration required as documented in LIMS::Local::IssueTracker
initialise with correct DBIX::Simple object and centre name via LIMS::DB
LIMS::Local::RfC->new( database => $dbix, centre => 'antarctica' );
It will always use the leeds centre for the tracker
=head1 DEPENDENCIES
LIMS::Local::IssueTracker
=head1 BUGS AND LIMITATIONS
There are no known bugs in this module.
Please report problems to Garry Quested (garry.quested@nhs.net)
Patches are welcome.
=head1 AUTHOR
Garry Quested (garry.quested@nhs.net)
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2017 Garry Quested (garry.quested@nhs.net). All rights reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
