BEGIN { # set test env otherwise get development config settings - unless explicitly
# set at command-line: "DANCER_ENVIRONMENT=development prove -lv t/"
$ENV{DANCER_ENVIRONMENT} ||= $ENV{PLACK_ENV} ||= 'test';
# set EMAIL_SENDER_TRANSPORT=TestFail at command line to force email failure:
$ENV{EMAIL_SENDER_TRANSPORT} ||= 'Test'; # default to Test if not set at command-line
}
use Test::More;
use Test::Most; # bail_on_fail
use Reporter::Class;
use Reporter::Routes;
require_ok('Reporter::Test'); # Data::Printer, Moo, etc
require_ok('Reporter::Routes');
use IO::All;
use Plack::Test;
use HTTP::Cookies;
use Reporter::Test;
use Data::Printer; # ddp \%ENV;
use HTTP::Request::Common; # GET
# create a testing object for app:
my $app = Reporter::Routes->to_app;
isa_ok( $app, 'CODE' );
my $test = Plack::Test->create($app);
# create a testing object for model:
my $model = Reporter::Test->new->app->model;
# get model dbix (using sqlite db):
my $dbix = $model->db->dbix; # ddp $dbix->dbh->{Name};
my $now = DateTime->now;
# check test scripts using sqlite in-memory db:
bail_on_fail;
like ($dbix->dbh->{Name}, qr/:memory:/, 'sqlite db in use');
run_schema(); # create tables & add some data (users, requests, request_specimen, etc)
my $user_id = 1;
{ # userid = username, incorrect password:
my %params = ( userid => 'queenie', password => 'queenie' );
my $res = $model->authenticate_user(\%params); # ddp $res;
is($res, 0, 'incorrect password');
}
{ # userid = username, correct password:
my %params = ( userid => 'queenie', password => 'Queenie' );
my $res = $model->authenticate_user(\%params); # ddp $res;
is( ref $res, 'HASH', 'authenticate returned hashref' );
is( $res->{username}, 'queenie', 'username matches for userid = username' );
is( $res->{id}, $user_id, 'user id matches' );
}
{ # userid = email, correct password:
my %params = ( userid => 'queenie@mail.com', password => 'Queenie' );
my $res = $model->authenticate_user(\%params); # ddp $res;
is( ref $res, 'HASH', 'authenticate returned hashref' );
is( $res->{username}, 'queenie', 'username matches for userid = email' );
}
{ # get reports for user #1:
my $n = get_reports_for_user($user_id);
is( $n, 0, "no reports for user id $user_id" );
}
{ # add some draft_reports:
my %h = (
user_id => $user_id,
request_id => 1, # will auto-increment in loop
diagnosis_id => 1,
);
$dbix->insert('request_draft_report', \%h) && $h{request_id}++ for (1..5);
# my $ref = $dbix->select('request_draft_report', '*')->hashes; p $ref;
# my $n = $dbix->count('request_draft_report'); p $n;
}
{ # get reports for user #1:
my $n = get_reports_for_user($user_id);
is( $n, 5, "5 reports for user id $user_id" );
}
{ # user reports:
my $res = $model->user_reports_list($user_id); # p $res;
is ( ref $res, 'HASH', 'user reports returned hashref' );
is ( ref $res->{reports}, 'ARRAY', 'reports is in list format' );
is ( @{ $res->{reports} }, 5, '5 reports returned' );
is( ref $res->{specimen}, 'ARRAY', 'specimen is in list format' );
# contains 5 PB's:
is ( $res->{specimen}->[0]->{id}, 'PB', 'expected sample type' );
is ( $res->{specimen}->[0]->{n}, 5, 'expected sample number' );
}
{ # new report:
my %h = (
biopsy_site => 'biopsy site',
clinical_details => 'clinical details',
comment => 'comment',
created_at => $now,
diagnosis_id => 1,
gross_description => 'gross description',
morphology => 'morphology',
request_id => 6,
request_notes => 'request notes',
secondary_diagnosis_id => undef,
specimen_quality => 'specimen quality',
status => 'new',
user_id => $user_id,
);
my $res = $model->save_report(\%h); # p $res;
is ( ref $res, 'HASH', 'save report returned hashref' );
is ( $res->{success}, 1, 'new record created successfully');
my $ref = $dbix->select('request_draft_report','*', { request_id => 6 })->hash; # p $ref;
is_deeply( $ref, \%h, 'data structures identical' );
}
{ # user roles:
my $response = $test->request( POST '/login',
[ userid => 'queenie', password => 'Queenie' ] ); # p $response;
# handle cookies for next request:
my $cookie_jar = HTTP::Cookies->new;
$cookie_jar->extract_cookies($response);
# my @cookies;
# $cookie_jar->scan( sub { @cookies = @_ }); p \@cookies;
# create HTTP::Request object and add cookies to it:
my $request = GET 'http://localhost/'; # full url to match cookie expectation
$cookie_jar->add_cookie_header( $request ); # p $request->dump;
# resubmit, should get search page:
my $content = $test->request( $request ); # p $content;
like( $content->as_string, qr/Miranda(\s+)RICHARDSON/, 'logged in user displayed' );
unlike( $content->as_string, qr/register/, 'register link not present' );
# error if requested directly:
$request = GET 'http://localhost/register'; # full url to match cookie expectation
$cookie_jar->add_cookie_header( $request ); # p $request->dump;
# resubmit, should get search page:
$content = $test->request( $request ); # p $content;
is( $content->code, 403, 'forbidden request' );
{ # register admin user role:
my %h = (
user_id => $user_id,
function_id => 1,
function_name => 'admin',
);
$dbix->insert('user_permission_view', \%h);
# login again:
$response = $test->request( POST 'http://localhost/login',
[ userid => 'queenie', password => 'Queenie' ] ); # p $response;
my $cookie_jar = HTTP::Cookies->new;
$cookie_jar->extract_cookies($response);
# request register link:
$request = GET 'http://localhost/register'; # full url to match cookie expectation
$cookie_jar->add_cookie_header( $request ); # p $request->dump;
$content = $test->request( $request ); # p $content;
is( $content->code, 200, 'allowed request' );
like( $content->as_string, qr/register/, 'register link now present' );
}
}
{ # register new user:
# check email transport set to test or die:
like( $ENV{EMAIL_SENDER_TRANSPORT}, qr/Test/, 'safe email transport set' )
or BAIL_OUT('unsafe email transport set');
# login:
my $response = $test->request( POST '/login',
[ userid => 'queenie', password => 'Queenie' ] ); # p $response;
# handle cookies for next request:
my $cookie_jar = HTTP::Cookies->new;
$cookie_jar->extract_cookies($response);
# create HTTP::Request object and add cookies to it:
my $request = GET 'http://localhost/register'; # full url to match cookie expectation
$cookie_jar->add_cookie_header( $request ); # p $request->dump;
# resubmit, should get registration page:
my $content = $test->request( $request ); # p $content->as_string;
my %user = (
first_name => 'tony',
last_name => 'robinson',
email => 'baldrick@email.com',
username => 'baldrick',
password => 'Imbecile',
);
$request = POST 'http://localhost/register', \%user; # full url to match cookie expectation
$cookie_jar->add_cookie_header( $request ); # p $request->dump;
$content = $test->request( $request ); # p $content->as_string; exit;
# my @deliveries = Email::Sender::Simple->default_transport->deliveries; p \@deliveries; exit;
is( $content->code, 200, 'request OK' );
my $content_string = $content->as_string; # p $content_string;
# uncomment to dump html to file:
# io('/tmp/draft_reporter_email_message.html')->print($content_string);
# success or failure depends on $ENV{EMAIL_SENDER_TRANSPORT} setting:
my $status_msg = $ENV{EMAIL_SENDER_TRANSPORT} eq 'TestFail'
? 'email failed: test delivery failure' : 'Message sent OK';
like( $content_string, qr/$status_msg/, 'expected test email response' );
like( $content_string, qr/to: $user{email}/, 'expected user email' );
like( $content_string, qr/from: no-reply\@hmds.info/, 'expected from address' );
like( $content_string, qr/reply-to: hmds.lth\@nhs.net/, 'expected reply-to address' );
like( $content_string, qr/cc: hmds.lth\@nhs.net/, 'expected copy-to address' );
like( $content_string, qr/subject: HMDS draft reporter registration/,
'expected subject line' );
like( $content_string, qr/Your HMDS draft reporter registration details/,
'expected text body' );
like( $content_string, qr/username: $user{email}/, 'expected username' ); # email NOT username
like( $content_string, qr/password: $user{password}/, 'expected password' );
# test Email::Sender::Simple->default_transport->deliveries:
SKIP: { # only tests headers, doesn't test any more than above $message:
$ENV{EMAIL_SENDER_TRANSPORT} eq 'Test'
or skip 'unsuitable EMAIL_SENDER_TRANSPORT setting', 4;
my @deliveries = Email::Sender::Simple->default_transport->deliveries; # p \@deliveries;
my $ref = $deliveries[0]; # only 1 msg
is( $ref->{envelope}->{from}, 'no-reply@hmds.info',
'expected from address' );
for my $recipient ($user{email}, 'hmds.lth@nhs.net') {
my $n = grep { $recipient eq $_ } @{ $ref->{envelope}->{to} }; # p $n;
is( $n, 1, 'expected recipient' );
}
is( scalar @{ $ref->{successes} }, 2,
'expected number of recipient successes');
}
}
done_testing(41);
sub get_reports_for_user {
my $user_id = shift;
my %h = (
user_id => $user_id,
page => 1,
uri => '/',
);
my $res = $model->get_reports_for_user(\%h); # ddp $res;
my $n = @{ $res->{reports} };
return $n;
}
sub run_schema {
my @schema = _schema();
do { $dbix->dbh->do($_) || die $dbix->error } foreach @schema; # $dbix->error doesn't work here
{ # draft_report_users & users table:
my %h = (
username => 'queenie',
first_name => 'miranda',
last_name => 'richardson',
password => 'WdQRFOH9t2KmvPpjgHCjTunkDpM', # sha1 Queenie
email => 'queenie@mail.com',
);
$dbix->insert($_, \%h) for qw(draft_report_users users);
}
{ # requests (5):
my %h = (
request_number => 1, # will auto-increment in loop
year => $now->year,
patient_case_id => 1,
status_option_id => 1,
referrer_department_id => 1,
);
$dbix->insert('requests', \%h) && $h{request_number}++ for (1..5);
}
{ # request_specimen (5) & specimen:
my $i = 1;
$dbix->insert('specimens',
{ sample_code => 'PB', description => 'blood' });
$dbix->insert('request_specimen',
{ request_id => $i++, specimen_id => 1}) for (1..5);
}
{ # diagnoses:
my %h = (
name => 'CLL',
icdo3 => '9823/3'
);
$dbix->insert('diagnoses', \%h);
}
}
sub _schema {
return (
q{
CREATE TABLE draft_report_users (
id INTEGER PRIMARY KEY AUTOINCREMENT,
username VARCHAR,
first_name VARCHAR,
last_name VARCHAR,
password VARCHAR,
email VARCHAR
)
},
q{
CREATE TABLE users (
id INTEGER PRIMARY KEY AUTOINCREMENT,
username VARCHAR,
first_name VARCHAR,
last_name VARCHAR,
password VARCHAR,
email VARCHAR,
active VARCHAR NOT NULL DEFAULT 'yes'
)
},
q{
CREATE TABLE request_draft_report (
user_id INTEGER,
request_id INTEGER,
request_notes VARCHAR,
clinical_details VARCHAR,
biopsy_site VARCHAR,
gross_description VARCHAR,
morphology VARCHAR,
comment VARCHAR,
status VARCHAR,
diagnosis_id INTEGER,
secondary_diagnosis_id INTEGER,
specimen_quality INTEGER,
created_at DATETIME,
updated_at DATETIME
)
},
q{
CREATE TABLE requests (
id INTEGER PRIMARY KEY AUTOINCREMENT,
request_number INTEGER,
year INTEGER,
patient_case_id INTEGER,
referrer_department_id INTEGER,
status_option_id INTEGER,
created_at DATETIME,
updated_at DATETIME
)
},
q{
CREATE TABLE request_specimen (
request_id INTEGER,
specimen_id INTEGER
)
},
q{
CREATE TABLE specimens (
id INTEGER PRIMARY KEY AUTOINCREMENT,
sample_code TEXT,
description TEXT,
active TEXT
)
},
q{
CREATE TABLE diagnoses (
id INTEGER PRIMARY KEY AUTOINCREMENT,
name TEXT,
icdo3 TEXT,
diagnostic_category_id INTEGER,
active TEXT
)
},
q{
CREATE TABLE user_permission_view (
user_id INTEGER,
function_id INTEGER,
function_name VARCHAR
)
}
);
}
