view release on metacpan or  search on metacpan

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

    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)

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

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