File Coverage

blib/lib/App/Dochazka/REST/Test.pm

Criterion	Covered	Total	%
statement	78	512	15.2
branch	2	122	1.6
condition	0	9	0.0
subroutine	26	62	41.9
pod	20	32	62.5
total	126	737	17.1

# *************************************************************************
# Copyright (c) 2014-2015, SUSE LLC
#
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice,
# this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# 3. Neither the name of SUSE LLC nor the names of its contributors may be
# used to endorse or promote products derived from this software without
# specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# *************************************************************************

# ------------------------
# Test helper functions module
# ------------------------

package App::Dochazka::REST::Test;

use strict;
use warnings;

use App::CELL qw( $CELL $log $meta $site );
use App::Dochazka::Common;
use App::Dochazka::REST;
use App::Dochazka::REST::Dispatch;
use App::Dochazka::REST::ConnBank qw( $dbix_conn conn_up );
use App::Dochazka::REST::Util qw( hash_the_password );
use App::Dochazka::REST::Model::Activity;
use App::Dochazka::REST::Model::Component;
use App::Dochazka::REST::Model::Privhistory qw( get_privhistory );
use App::Dochazka::REST::Model::Schedhistory qw( get_schedhistory );
use App::Dochazka::REST::Model::Shared qw( cud_generic noof select_single );
use Authen::Passphrase::SaltedDigest;
use Data::Dumper;
use HTTP::Request::Common qw( GET PUT POST DELETE );
use JSON;
use Params::Validate qw( :all );
use Test::JSON;
use Test::More;
use Try::Tiny;
use Web::MREST;



=head1 NAME

App::Dochazka::REST::Test - Test helper functions





=head1 DESCRIPTION

This module provides helper code for unit tests.

=cut




=head1 EXPORTS

=cut

use Exporter qw( import );
our @EXPORT = qw(
    initialize_regression_test $faux_context
    req dbi_err docu_check
    create_bare_employee create_active_employee create_inactive_employee
    delete_bare_employee delete_employee_by_nick
    create_testing_activity delete_testing_activity
    create_testing_interval delete_testing_interval
    create_testing_component delete_testing_component
    create_testing_schedule delete_testing_schedule delete_all_attendance_data
    gen_activity gen_employee gen_interval gen_lock
    gen_privhistory gen_schedhistory gen_schedule
    test_sql_success test_sql_failure do_select_single
    test_employee_list get_aid_by_code test_schedule_model
);




=head1 PACKAGE VARIABLES

=cut

# faux context
our $faux_context;

# dispatch table with references to HTTP::Request::Common functions
my %methods = (
    GET => \&GET,
    PUT => \&PUT,
    POST => \&POST,
    DELETE => \&DELETE,
);




=head1 FUNCTIONS

=cut


=head2 initialize_regression_test

Perform the boilerplate tasks that have to be done at the beginning of every
test file that communicates with the Web::MREST server and/or the PostgreSQL
database. Since both Web::MREST and PostgreSQL are external resources,
tests that make use of them are more than mere unit tests

While some test files do not need *all* of these initialization steps,
there is no harm in running them.

The t/unit/ subdirectory is reserved for test files that need *none* of
these initialization steps. Having them in a separate subdirectory enables
them to be run separately.

=cut

sub initialize_regression_test {

    my $status = Web::MREST::init(
        distro => 'App-Dochazka-REST',
        sitedir => '/etc/dochazka-rest',
    );
    plan skip_all => "Web::MREST::init failed: " . $status->text unless $status->ok;

    #diag( "DOCHAZKA_STATE_DIR is set to " . $site->DOCHAZKA_STATE_DIR );

    note( "Set log level" );
    $log->init(
        ident => $site->MREST_APPNAME,
        debug_mode => 1,
    );

    note( "Initialize" );
    try {
        App::Dochazka::REST::Dispatch::init();
    } catch {
        $status = $CELL->status_not_ok;
    };
    plan skip_all => 'Integration testing environment not detected' unless $status->ok;

    note( "Check status of database server connection" );
    plan skip_all => "PostgreSQL server is unreachable" unless conn_up();

    my $eids = App::Dochazka::REST::get_eid_of( $dbix_conn, "root", "demo" );
    $site->set( 'DOCHAZKA_EID_OF_ROOT', $eids->{'root'} );
    $site->set( 'DOCHAZKA_EID_OF_DEMO', $eids->{'demo'} );

    is( $status->level, 'OK' );
    ok( $site->DOCHAZKA_EID_OF_ROOT );
    ok( $site->DOCHAZKA_EID_OF_DEMO );
    ok( $site->DOCHAZKA_TIMEZONE );

    $faux_context = { 'dbix_conn' => $dbix_conn, 'current' => { 'eid' => 1 } };
    $meta->set( 'META_DOCHAZKA_UNIT_TESTING' => 1 );

    note( "instantiate Web::Machine object for this application" );
    my $app = Web::Machine->new( resource => 'App::Dochazka::REST::Dispatch', )->to_app;

    note( "A PSGI application is a Perl code reference. It takes exactly " .
    "one argument, the environment and returns an array reference of exactly " .
    "three values." );
    is( ref($app), 'CODE' );

    note( 'initialize App::Dochazka::Common package variables $t, $today, etc.' );
    App::Dochazka::Common::init_timepiece();

    return $app;
}


=head2 status_from_json

L<App::Dochazka::REST> is designed to return status objects in the HTTP
response body. These, of course, are sent in JSON format. This simple routine
takes a JSON string and blesses it, thereby converting it back into a status
object.

FIXME: There may be some encoding issues here!

=cut

sub status_from_json {
    my ( $json ) = @_;
    bless from_json( $json ), 'App::CELL::Status';
}


=head2 req

Assemble and process a HTTP request. Takes the following positional arguments:

    * Plack::Test object
    * expected HTTP result code
    * user to authenticate with (can be 'root', 'demo', or 'active')
    * HTTP method
    * resource string
    * optional JSON string

If the HTTP result code is 200, the return value will be a status object, undef
otherwise.

=cut

sub req {
    my ( $test, $code, $user, $method, $resource, $json ) = validate_pos( @_, 1, 1, 1, 1, 1, 0 );

    if ( ref( $test ) ne 'Plack::Test::MockHTTP' ) {
        diag( "Plack::Test::MockHTTP object not passed to 'req' from " . (caller)[1] . " line " . (caller)[2] );
        BAIL_OUT(0);
    }

    # assemble request
    my %pl = (
        Accept => 'application/json',
        Content_Type => 'application/json',
    );
    if ( $json ) {
        $pl{'Content'} = $json;
    }
    my $r = $methods{$method}->( $resource, %pl );

    my $pass;
    if ( $user eq 'root' ) {
        $pass = 'immutable';
    } elsif ( $user eq 'inactive' ) {
        $pass = 'inactive';
    } elsif ( $user eq 'active' ) {
        $pass = 'active';
    } elsif ( $user eq 'demo' ) {
        $pass = 'demo';
    } else {
        #diag( "Unusual user $user - trying password $user" );
        $pass = $user;
    }

    $r->authorization_basic( $user, $pass );
    note( "About to send request $method $resource as $user " . ( $json ? "with $json" : "" ) );
    my $res = $test->request( $r );
    $code += 0;
    if ( $code != $res->code ) {
        diag( Dumper $res );
        BAIL_OUT(0);
    }
    is( $res->code, $code, "Response code is $code" );
    my $content = $res->content;
    if ( $content ) {
        #diag( Dumper $content );
        is_valid_json( $res->content, "Response entity is valid JSON" );
        my $status = status_from_json( $content );
        if ( my $location_header = $res->header( 'Location' ) ) {
            $status->{'location_header'} = $location_header;
        }
        return $status;
    }
    return;
}


=head2 dbi_err

Wrapper for 'req' intended to eliminate duplicated code on tests that are
expected to return DOCHAZKA_DBI_ERR. In addition to the arguments expected
by 'req', takes one additional argument, which should be:

    qr/error message subtext/

(i.e. a regex quote by which to test the $status->text)

=cut

sub dbi_err {
    my ( $test, $code, $user, $method, $resource, $json, $qr ) = validate_pos( @_, 1, 1, 1, 1, 1, 1, 1 );
    my $status = req( $test, $code, $user, $method, $resource, $json );
    is( $status->level, 'ERR' );
    ok( $status->text );
    if ( ! ( $status->text =~ $qr ) ) {
        diag( "$user $method $resource\n$json" );
        diag( $status->text . " does not match $qr" );
        BAIL_OUT(0);
    }
    like( $status->text, $qr );
}


=head2 docu_check

Check that the resource has on-line documentation (takes Plack::Test object
and resource name without quotes)

=cut

sub docu_check {
    my ( $test, $resource ) = @_;
    #diag( "Entering " . __PACKAGE__ . "::docu_check with argument $resource" );

    if ( ref( $test ) ne 'Plack::Test::MockHTTP' ) {
        diag( "Plack::Test::MockHTTP object not passed to 'req' from " . (caller)[1] . " line " . (caller)[2] );
        BAIL_OUT(0);
    }

    my $tn = "docu_check $resource ";
    my $t = 0;
    my ( $docustr, $docustr_len );
    #
    # - straight 'docu/pod' resource
    my $status = req( $test, 200, 'demo', 'POST', '/docu/pod', "\"$resource\"" );
    is( $status->level, 'OK', $tn . ++$t );
    is( $status->code, 'DISPATCH_ONLINE_DOCUMENTATION', $tn . ++$t );
    if ( exists $status->{'payload'} ) {
        ok( exists $status->payload->{'resource'}, $tn . ++$t );
        is( $status->payload->{'resource'}, $resource, $tn . ++$t );
        ok( exists $status->payload->{'documentation'}, $tn . ++$t );
        $docustr = $status->payload->{'documentation'};
        $docustr_len = length( $docustr );
        ok( $docustr_len > 10, $tn . ++$t );
        isnt( $docustr, 'NOT WRITTEN YET', $tn . ++$t );
    }
    #
    # - not a very thorough examination of the 'docu/html' version
    $status = req( $test, 200, 'demo', 'POST', '/docu/html', "\"$resource\"" );
    is( $status->level, 'OK', $tn . ++$t );
    is( $status->code, 'DISPATCH_ONLINE_DOCUMENTATION', $tn . ++$t );
    if ( exists $status->{'payload'} ) {
        ok( exists $status->payload->{'resource'}, $tn . ++$t );
        is( $status->payload->{'resource'}, $resource, $tn . ++$t );
        ok( exists $status->payload->{'documentation'}, $tn . ++$t );
        $docustr = $status->payload->{'documentation'};
        $docustr_len = length( $docustr );
        ok( $docustr_len > 10, $tn . ++$t );
        isnt( $docustr, 'NOT WRITTEN YET', $tn . ++$t );
    }
}


=head2 create_bare_employee

For use in tests only. Spawns an employee object and inserts it into the
database.

Takes PROPLIST which is passed through unmunged to the employee spawn method.

Returns the new Employee object.

=cut

sub create_bare_employee {
    my ( $PROPS ) = validate_pos( @_,
        { type => HASHREF },
    );

    hash_the_password( $PROPS );

    my $emp = App::Dochazka::REST::Model::Employee->spawn( $PROPS );
    is( ref($emp), 'App::Dochazka::REST::Model::Employee', 'create_bare_employee 1' );

    my $status = $emp->insert( $faux_context );
    if ( $status->not_ok ) {
        diag( "Employee insert method returned NOT_OK status in create_bare_employee" );
        diag( "test automation function, which was called from " . (caller)[1] . " line " . (caller)[2] );
        diag( "with arguments: " . Dumper( $PROPS ) );
        diag( "Full status returned by employee insert method:" );
        diag( Dumper $status );
        BAIL_OUT(0);
    }
    is( $status->level, "OK", 'create_bare_employee 2' );
    my $employee_object = $status->payload;
    is( ref( $employee_object ), 'App::Dochazka::REST::Model::Employee' );

    return $employee_object;
}


=head2 delete_bare_employee

Takes a single argument: the EID.

Loads the EID into a new Employee object and calls that object's delete method.

=cut

sub delete_bare_employee {
    my $eid = shift;
    note( "delete testing employee with EID $eid" );
    my $status = App::Dochazka::REST::Model::Employee->load_by_eid( $dbix_conn, $eid );
    if ( $status->not_ok ) {
        diag( "Employee load_by_eid method returned NOT_OK status in delete_bare_employee" );
        diag( "test automation function, which was called from " . (caller)[1] . " line " . (caller)[2] );
        diag( "with EID $eid" );
        diag( "Full status returned by Employee load_by_eid method:" );
        diag( Dumper $status );
        BAIL_OUT(0);
    }
    is( $status->level, 'OK', 'delete_bare_employee 1' );
    my $emp = $status->payload;
    $status = $emp->delete( $faux_context );
    if ( $status->not_ok ) {
        diag( Dumper $status );
        BAIL_OUT(0);
    }
    is( $status->level, 'OK', 'delete_bare_employee 2' );
    return;
}


sub _create_employee {
    my ( $test, $privspec ) = @_;

    note("create $privspec employee");
    my $eid = create_bare_employee( { nick => $privspec, password => $privspec } )->eid;
    my $status = req( $test, 201, 'root', 'POST', "priv/history/eid/$eid",
        "{ \"effective\":\"1892-01-01\", \"priv\":\"$privspec\" }" );
    ok( $status->ok, "Create $privspec employee 2" );
    is( $status->code, 'DOCHAZKA_CUD_OK', "Create $privspec employee 3" );
    return $eid;

}

=head2 create_active_employee

Create a testing employee with 'active' privilege. The employee will get an
'active' privhistory record with date 1892-01-01.

=cut

sub create_active_employee {
    my ( $test ) = @_;
    return _create_employee( $test, "active" );
}


=head2 create_inactive_employee

Create a testing employee with 'inactive' privilege. The employee will get an
'inactive' privhistory record with date 1892-01-01.

=cut

sub create_inactive_employee {
    my ( $test ) = @_;
    return _create_employee( $test, "inactive" );
}


=head2 delete_employee_by_nick

Delete testing employee (takes Plack::Test object and nick)

=cut

sub delete_employee_by_nick {
    my ( $test, $nick ) = @_;
    my ( $res, $status );

    # get and delete privhistory
    $status = get_privhistory( $faux_context, nick => $nick );
    if ( $status->level eq 'OK' and $status->code eq 'DISPATCH_RECORDS_FOUND' ) {
        my $ph = $status->payload->{'history'};
        # delete the privhistory records one by one
        foreach my $phrec ( @$ph ) {
            my $phid = $phrec->{phid};
            $status = req( $test, 200, 'root', 'DELETE', "priv/history/phid/$phid" );
            ok( $status->ok, "Delete employee by nick 2" );
            is( $status->code, 'DOCHAZKA_CUD_OK', "Delete employee by nick 3" );
        }
    } else {
        diag( "Unexpected return value from get_privhistory: " . Dumper( $status ) );
        BAIL_OUT(0);
    }

    # get and delete schedhistory
    $status = get_schedhistory( $faux_context, nick => $nick );
    if ( $status->level eq 'OK' and $status->code eq 'DISPATCH_RECORDS_FOUND' ) {
        my $sh = $status->payload->{'history'};
        # delete the schedhistory records one by one
        foreach my $shrec ( @$sh ) {
            my $shid = $shrec->{shid};
            $status = req( $test, 200, 'root', 'DELETE', "schedule/history/shid/$shid" );
            ok( $status->ok, "Delete employee by nick 5" );
            is( $status->code, 'DOCHAZKA_CUD_OK', "Delete employee by nick 5" );
        }
    } elsif ( $status->level eq 'NOTICE' and $status->code eq 'DISPATCH_NO_RECORDS_FOUND' ) {
        ok( 1, "$nick has no schedule history" );
    } else {
        diag( "Unexpected return value from get_schedhistory: " . Dumper( $status ) );
        BAIL_OUT(0);
    }

    # delete the employee record
    $status = req( $test, 200, 'root', 'DELETE', "employee/nick/$nick" );
    BAIL_OUT($status->text) unless $status->ok;
    is( $status->level, 'OK', "Delete employee by nick 6" );
    is( $status->code, 'DOCHAZKA_CUD_OK', "Delete employee by nick 7" );

    return;
}


=head2 create_testing_activity

Tests will need to set up and tear down testing activities

=cut

sub create_testing_activity {
    my %PROPS = @_;  # must be at least code

    my $act = App::Dochazka::REST::Model::Activity->spawn( \%PROPS );
    is( ref($act), 'App::Dochazka::REST::Model::Activity', 'create_testing_activity 1' );
    my $status = $act->insert( $faux_context );
    if ( $status->not_ok ) {
        BAIL_OUT( $status->code . " " . $status->text );
    }
    is( $status->level, "OK", 'create_testing_activity 2' );
    return $status->payload;
}


=head2 delete_testing_activity

Tests will need to set up and tear down testing activities

=cut

sub delete_testing_activity {
    my $aid = shift;

    my $status = App::Dochazka::REST::Model::Activity->load_by_aid( $dbix_conn, $aid );
    is( $status->level, 'OK', 'delete_testing_activity 1' );
    my $act = $status->payload;
    $status = $act->delete( $faux_context );
    is( $status->level, 'OK', 'delete_testing_activity 2' );
    return;
}


=head2 create_testing_interval

Tests will need to set up and tear down testing intervals

=cut

sub create_testing_interval {
    my %PROPS = @_;  # must be at least code

    my $act = App::Dochazka::REST::Model::Interval->spawn( \%PROPS );
    is( ref($act), 'App::Dochazka::REST::Model::Interval', 'create_testing_interval 1' );
    my $status = $act->insert( $faux_context );
    if ( $status->not_ok ) {
        BAIL_OUT( $status->code . " " . $status->text );
    }
    is( $status->level, "OK", 'create_testing_interval 2' );
    return $status->payload;
}


=head2 delete_testing_interval

Tests will need to set up and tear down testing intervals

=cut

sub delete_testing_interval {
    my $iid = shift;

    my $status = App::Dochazka::REST::Model::Interval->load_by_iid( $dbix_conn, $iid );
    is( $status->level, 'OK', 'delete_testing_interval 1' );
    my $int = $status->payload;
    $status = $int->delete( $faux_context );
    is( $status->level, 'OK', 'delete_testing_interval 2' );
    return;
}


=head2 create_testing_component

Tests will need to set up and tear down testing components

=cut

sub create_testing_component {
    my %PROPS = @_;  # must be at least path

    my $comp = App::Dochazka::REST::Model::Component->spawn( \%PROPS );
    is( ref($comp), 'App::Dochazka::REST::Model::Component', 'create_testing_component 1' );
    my $status = $comp->insert( $faux_context );
    if ( $status->not_ok ) {
        BAIL_OUT( $status->code . " " . $status->text );
    }
    is( $status->level, "OK", 'create_testing_component 2' );
    return $status->payload;
}


=head2 delete_testing_component

Tests will need to set up and tear down testing components

=cut

sub delete_testing_component {
    my $cid = shift;

    my $status = App::Dochazka::REST::Model::Component->load_by_cid( $dbix_conn, $cid );
    is( $status->level, 'OK', 'delete_testing_component 1' );
    my $act = $status->payload;
    $status = $act->delete( $faux_context );
    is( $status->level, 'OK', 'delete_testing_component 2' );
    return;
}


=head2 test_schedule_model

Creates and returns a testing schedule without needing a L<Plack::Test> object.

=cut

sub test_schedule_model {
    my $intvls = shift;

    note('create an arbitrary schedule' );
    note('at the beginning, count of schedintvls should be 0');
    is( noof( $dbix_conn, 'schedintvls' ), 0 );

    note('spawn a schedintvls ("scratch schedule") object');
    my $schedintvls = App::Dochazka::REST::Model::Schedintvls->spawn;
    ok( ref($schedintvls), "object is a reference" );
    isa_ok( $schedintvls, 'App::Dochazka::REST::Model::Schedintvls' );
    ok( defined( $schedintvls->{ssid} ), "Scratch SID is defined" );
    ok( $schedintvls->{ssid} > 0, "Scratch SID is > 0" );

    note('insert a schedule (i.e. a list of schedintvls)');
    $schedintvls->{intvls} = $intvls;

    note('insert all the schedintvls in one go');
    my $status = $schedintvls->insert( $dbix_conn );
    diag( $status->text ) unless $status->ok;
    ok( $status->ok, "OK scratch intervals inserted OK" );
    ok( $schedintvls->ssid, "OK there is a scratch SID" );
    my $count = scalar @{ $schedintvls->{intvls} };
    ok( $count );

    note("after insert, count of schedintvls should be $count");
    is( noof( $dbix_conn, 'schedintvls' ), $count );

    note('load the schedintvls, translating them as we go');
    $status = $schedintvls->load( $dbix_conn );
    ok( $status->ok, "OK scratch intervals translated OK" );
    is( scalar @{ $schedintvls->{intvls} }, $count, "Still have $count intervals" );
    is( scalar @{ $schedintvls->{schedule} }, $count, "And now have $count translated intervals as well" );
    like( $status->code, qr/$count rows/, "status code says $count rows" );
    like( $status->text, qr/$count rows/, "status code says $count rows" );
    ok( exists $schedintvls->{schedule}->[0]->{high_time}, "Conversion to hash OK" );
    is_valid_json( $schedintvls->json );

    note('insert the JSON into the schedules table');
    my $schedule = App::Dochazka::REST::Model::Schedule->spawn(
        schedule => $schedintvls->json,
        scode => 'test1',
        remark => 'TESTING',
    );
    $status = $schedule->insert( $faux_context );
    ok( $status->ok, "Schedule insert OK" );
    ok( $schedule->sid > 0, "There is an SID" );
    is( $schedule->scode, 'test1', "scode accessor returns correct value" );
    is_valid_json( $schedule->schedule );
    is( $schedule->remark, 'TESTING' );

    note( 'delete the schedintvls' );
    $status = $schedintvls->delete( $dbix_conn );
    ok( $status->ok, "scratch intervals deleted" );
    like( $status->text, qr/$count record/, "$count records deleted" );
    is( noof( $dbix_conn, 'schedintvls' ), 0 );

    return $schedule;
}


=head2 create_testing_schedule

Tests will need to set up and tear down testing schedules. Takes a Plack::Test
object as its only argument.

=cut

sub create_testing_schedule {
    my ( $test ) = @_;

    note( "Create a testing schedule" );

    my $intvls = { "schedule" => [
        "[2000-01-02 12:30, 2000-01-02 16:30)",
        "[2000-01-02 08:00, 2000-01-02 12:00)",
        "[2000-01-01 12:30, 2000-01-01 16:30)",
        "[2000-01-01 08:00, 2000-01-01 12:00)",
        "[1999-12-31 12:30, 1999-12-31 16:30)",
        "[1999-12-31 08:00, 1999-12-31 12:00)",
    ], "scode" => 'KOBOLD' };
    my $intvls_json = JSON->new->utf8->canonical(1)->encode( $intvls );
    #
    # - request as root
    my $status = req( $test, 201, 'root', 'POST', "schedule/new", $intvls_json );
    is( $status->level, 'OK', 'POST schedule/new returned OK status' );
    is( $status->code, 'DISPATCH_SCHEDULE_INSERT_OK', "POST schedule/new code " . $status->code );
    ok( exists $status->{'payload'} );
    ok( exists $status->payload->{'sid'}, 'there is a SID' );
    ok( exists $status->payload->{'scode'}, 'there is an scode' );

    return $status->payload->{'sid'};
}


=head2 delete_testing_schedule

Tests will need to set up and tear down testing schedule. Takes a SID as its
only argument.

=cut

sub delete_testing_schedule {
    my ( $sid ) = @_;

    note( "delete testing schedule (SID $sid)" );

    my $status = App::Dochazka::REST::Model::Schedule->load_by_sid( $dbix_conn, $sid );
    is( $status->level, 'OK', 'delete_testing_schedule: load OK' );
    if ( $status->not_ok ) {
        diag( Dumper $status );
        BAIL_OUT(0);
    }

    my $sched = $status->payload;
    $status = $sched->delete( $faux_context );
    is( $status->level, 'OK', 'delete_testing_schedule: delete OK' );
    if ( $status->not_ok ) {
        diag( Dumper $status );
        BAIL_OUT(0);
    }
    return;
}


=head2 delete_all_attendance_data

Wipe out all attendance data by deleting all rows from all tables (in the correct
order).

To be called like this:

    $status = delete_all_attendance_data();
    BAIL_OUT(0) unless $status->ok;

=cut

sub delete_all_attendance_data {

    note( 'delete locks' );
    my $status = cud_generic(
        conn => $dbix_conn,
        eid => $site->DOCHAZKA_EID_OF_ROOT,
        sql => 'DELETE FROM locks',
    );
    is( $status->level, 'OK' );
    is( $status->code, 'DOCHAZKA_CUD_OK' );
    return $status unless $status->ok;

    note( 'delete intervals' );
    $status = cud_generic(
        conn => $dbix_conn,
        eid => $site->DOCHAZKA_EID_OF_ROOT,
        sql => 'DELETE FROM intervals',
    );
    is( $status->level, 'OK' );
    is( $status->code, 'DOCHAZKA_CUD_OK' );
    return $status unless $status->ok;

    note( 'delete activities' );
    $status = cud_generic(
        conn => $dbix_conn,
        eid => $site->DOCHAZKA_EID_OF_ROOT,
        sql => 'DELETE FROM activities',
    );
    is( $status->level, 'OK' );
    is( $status->code, 'DOCHAZKA_CUD_OK' );
    return $status unless $status->ok;

    note( 're-initialize activities table' );
    $status = App::Dochazka::REST::initialize_activities_table( $dbix_conn );
    return $status unless $status->ok;

    note( 'delete schedhistory' );
    $status = cud_generic(
        conn => $dbix_conn,
        eid => $site->DOCHAZKA_EID_OF_ROOT,
        sql => 'DELETE FROM schedhistory',
    );
    is( $status->level, 'OK' );
    is( $status->code, 'DOCHAZKA_CUD_OK' );
    return $status unless $status->ok;

    note( 'delete privhistory' );
    $status = cud_generic(
        conn => $dbix_conn,
        eid => $site->DOCHAZKA_EID_OF_ROOT,
        sql => 'DELETE FROM privhistory WHERE eid != ?',
        bind_params => [ $site->DOCHAZKA_EID_OF_ROOT ],
    );
    is( $status->level, 'OK' );
    is( $status->code, 'DOCHAZKA_CUD_OK' );
    return $status unless $status->ok;

    note( 'delete schedules' );
    $status = cud_generic(
        conn => $dbix_conn,
        eid => $site->DOCHAZKA_EID_OF_ROOT,
        sql => 'DELETE FROM schedules WHERE scode != \'DEFAULT\'',
    );
    is( $status->level, 'OK' );
    is( $status->code, 'DOCHAZKA_CUD_OK' );
    return $status unless $status->ok;

    note( 'delete tempintvls' );
    $status = cud_generic(
        conn => $dbix_conn,
        eid => $site->DOCHAZKA_EID_OF_ROOT,
        sql => 'DELETE FROM tempintvls',
    );
    is( $status->level, 'OK' );
    is( $status->code, 'DOCHAZKA_CUD_OK' );
    return $status unless $status->ok;

    note( 'delete employees' );
    $status = cud_generic(
        conn => $dbix_conn,
        eid => $site->DOCHAZKA_EID_OF_ROOT,
        sql => 'DELETE FROM employees WHERE eid != ? AND eid != ?',
        bind_params => [ $site->DOCHAZKA_EID_OF_ROOT, $site->DOCHAZKA_EID_OF_DEMO ],
    );
    is( $status->level, 'OK' );
    is( $status->code, 'DOCHAZKA_CUD_OK' );

    return $status;
}


#
# functions to perform class-specific 'create', 'retrieve', 'delete', etc. actions
#

sub gen_activity {
    my $dis = shift;
    my $code = 'FOOBAR';

    if ( $dis eq 'create' ) {

        # create 'FOOBAR' activity
        my $act = App::Dochazka::REST::Model::Activity->spawn( code => $code );
        my $status = $act->insert( $faux_context );
        if( $status->level ne 'OK' ) {
            diag( Dumper $status );
            BAIL_OUT(0);
        }
        is( $status->level, 'OK' );
        $act = $status->payload;
        is( $act->code, $code );
        ok( $act->aid > 5 );
        return $act;

    } elsif ( $dis eq 'retrieve' ) {

        my $status = App::Dochazka::REST::Model::Activity->load_by_code( $dbix_conn, $code );
        return $status;

    } elsif ( $dis eq 'delete' ) {

        my $status = App::Dochazka::REST::Model::Activity->load_by_code( $dbix_conn, $code );
        is( $status->level, 'OK' );
        my $act = $status->payload;
        $status = $act->delete( $faux_context );
        is( $status->level, 'OK' );
        return;

    }
    diag( "gen_activity: AAAAAAHHHHH@@@!! \$dis " . Dumper( $dis ) );
    BAIL_OUT(0);
}


sub gen_employee {
    my $dis = shift;
    my $nick = 'bubbaTheCat';

    if ( $dis eq 'create' ) {

        # create bubbaTheCat employee
        my $emp = App::Dochazka::REST::Model::Employee->spawn( nick => $nick );
        my $status = $emp->insert( $faux_context );
        is( $status->level, 'OK' );
        $emp = $status->payload;
        is( $emp->nick, $nick );
        ok( $emp->eid > 2 );  # root is 1, demo is 2
        return $emp;

    } elsif ( $dis eq 'retrieve' ) {

        my $status = App::Dochazka::REST::Model::Employee->load_by_nick( $dbix_conn, $nick );
        return $status;

    } elsif ( $dis eq 'delete' ) {

        my $status = App::Dochazka::REST::Model::Employee->load_by_nick( $dbix_conn, $nick );
        is( $status->level, 'OK' );
        my $emp = $status->payload;
        $status = $emp->delete( $faux_context );
        is( $status->level, 'OK' );
        return;

    }
    diag( "gen_employee: AAAAAAHHHHH@@@!! \$dis " . Dumper( $dis ) );
    BAIL_OUT(0);
}


sub gen_interval {
    my $dis = shift;
    my $eid = $site->DOCHAZKA_EID_OF_ROOT;
    my $aid = App::Dochazka::REST::Model::Activity->load_by_code( $dbix_conn, 'WORK' )->aid;
    if ( $dis eq 'create' ) {

        # create an interval
        my $int = App::Dochazka::REST::Model::Interval->spawn(
            eid => $eid,
            aid => $aid,
            intvl => "['1950-06-30 09:00', '1950-06-30 10:00')",
        );
        my $status = $int->insert( $faux_context );
        is( $status->level, 'OK' );
        $int = $status->payload;
        is( $int->eid, $eid );
        is( $int->aid, $aid );
        ok( $int->iid > 0 );
        # FIXME: use "state" variable to store iid for use in retrieve
        return $int;

    } elsif ( $dis eq 'retrieve' ) {

#        my $status = App::Dochazka::REST::Model::Interval->load_by_iid( $dbix_conn, $iid );
#        return $status;

    } elsif ( $dis eq 'delete' ) {

    }
    diag( "gen_interval: AAAAAAHHHHH@@@!! \$dis " . Dumper( $dis ) );
    BAIL_OUT(0);
}


sub gen_lock {
    my $dis = shift;
    if ( $dis eq 'create' ) {

    } elsif ( $dis eq 'retrieve' ) {

    } elsif ( $dis eq 'delete' ) {

    }
    diag( "gen_lock: AAAAAAHHHHH@@@!! \$dis " . Dumper( $dis ) );
    BAIL_OUT(0);
}


sub gen_privhistory {
    my $dis = shift;
    if ( $dis eq 'create' ) {

    } elsif ( $dis eq 'retrieve' ) {

    } elsif ( $dis eq 'delete' ) {

    }
    diag( "gen_privhistory: AAAAAAHHHHH@@@!! \$dis " . Dumper( $dis ) );
    BAIL_OUT(0);
}

sub gen_schedhistory {
    my $dis = shift;
    if ( $dis eq 'create' ) {

    } elsif ( $dis eq 'retrieve' ) {

    } elsif ( $dis eq 'delete' ) {

    }
    diag( "gen_schedhistory: AAAAAAHHHHH@@@!! \$dis " . Dumper( $dis ) );
    BAIL_OUT(0);
}

sub gen_schedule {
    my $dis = shift;
    if ( $dis eq 'create' ) {

    } elsif ( $dis eq 'retrieve' ) {

    } elsif ( $dis eq 'delete' ) {

    }
    diag( "gen_schedule: AAAAAAHHHHH@@@!! \$dis " . Dumper( $dis ) );
    BAIL_OUT(0);
}

sub test_sql_success {
    my ( $conn, $expected_rv, $sql ) = @_;
    my ( $rv, $errstr );
    try {
        $conn->run( fixup => sub {
            $rv = $_->do($sql);
        });
    } catch {
        $errstr = $_;
    };
    if ( $errstr ) {
        diag( "Unexpected error in test_sql_success: $errstr" );
        diag( "Called from " . (caller)[1] . " line " . (caller)[2] );
        BAIL_OUT(0);
    }
    is( $rv, $expected_rv, "successfully executed $sql" );
}

sub test_sql_failure {
    my ( $conn, $expected_err, $sql ) = @_;
    my ( $rv, $errstr );
    try {
        $conn->run( fixup => sub {
            $rv = $_->do($sql);
        });
    } catch {
        $errstr = $_;
    };
    is( $rv, undef, "DBI returned undef" );
    like( $errstr, $expected_err, "DBI errstr is as expected" );
}

sub do_select_single {
    my ( $conn, $sql, @keys ) = @_;
    #diag( "do_select_single: connection OK" ) if ref( $conn ) eq 'DBIx::Connector';
    #diag( "do_select_single: SQL statement is $sql" ) if $sql;
    #diag( "do_select_single: keys are ", join(', ', @keys) ) if @keys;
    my $status = select_single( conn => $conn, sql => $sql, keys => \@keys );
    #diag( Dumper $status );
    is( $status->level, 'OK' );
    is( $status->code, 'DISPATCH_RECORDS_FOUND' );
    ok( $status->payload );
    is( ref( $status->payload ), 'ARRAY' );
    return @{ $status->payload };
}

sub test_employee_list {
    my ( $status, $nicks ) = @_;
    is( $status->level, 'OK' );
    is( $status->code, 'DISPATCH_LIST_EMPLOYEE_NICKS' );
    is_deeply( $status->payload, $nicks );
}

sub get_aid_by_code {
    my ( $test, $code ) = @_;
    my $status = req( $test, 200, 'root', 'GET', "activity/code/$code" );
    is( $status->level, 'OK' );
    is( $status->code, 'DISPATCH_ACTIVITY_FOUND' );
    ok( $status->{'payload'} );
    ok( $status->{'payload'}->{'aid'} );
    is( $status->{'payload'}->{'code'}, uc( $code ) );
    return $status->{'payload'}->{'aid'};
}

1;