view release on metacpan or  search on metacpan

lib/App/Dochazka/REST/Test.pm  view on Meta::CPAN

# ************************************************************************* 
# 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

lib/App/Dochazka/REST/Test.pm  view on Meta::CPAN

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);
    }