File Coverage

blib/lib/Web/MREST/Test.pm

Criterion	Covered	Total	%
statement	97	131	74.0
branch	15	26	57.6
condition	7	7	100.0
subroutine	21	23	91.3
pod	5	5	100.0
total	145	192	75.5

# *************************************************************************
# Copyright (c) 2014-2022, 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
# ------------------------


use strict;
use warnings;

use App::CELL qw( $CELL $log $meta $site );
use Data::Dumper;
use File::HomeDir;
use HTTP::Request;
use JSON;
use Log::Any::Adapter;
use Params::Validate qw( :all );
use Plack::Test;
use Test::JSON;
use Test::More;
use Try::Tiny;
use Web::Machine;
use Web::MREST;



=head1 NAME

Web::MREST::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_unit req llreq docu_check );




=head1 PACKAGE VARIABLES

=cut

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




=head1 FUNCTIONS

=cut


=head2 initialize_unit

Perform the boilerplate tasks that have to be done at the beginning of every
unit. Takes a PARAMHASH with two optional parameters:

    'class' => class into which Web::Machine object is to be blessed
    'sitedir' => sitedir parameter to be passed to Web::MREST::init

=cut

    my %ARGS = @_;
    note( "Initializing unit " . (caller)[1] . " with arguments " . Dumper( \%ARGS ) );
    my $class = $ARGS{'class'} || undef;
    my %init_options = $ARGS{'sitedir'}
        ? ( 'sitedir' => $ARGS{'sitedir'} )
        : ();

    # zero logfile and tell Log::Any to log to it
    my $log_file_spec = File::HomeDir->my_home . "/mrest.log";
    unlink $log_file_spec;
    Log::Any::Adapter->set( 'File', $log_file_spec );
    $log->init( ident => 'MREST_UNIT_TEST' );

    # load configuration parameters
    my $status = Web::MREST::init( %init_options );
    is( $status->level, 'OK' );

    note( 'check that site configuration parameters were loaded' );
    is_deeply( [ $site->MREST_SUPPORTED_CONTENT_TYPES ], [ [ 'application/json' ] ],
        'configuration parameters loaded?' );

    # set debug mode
    $log->debug_mode( $site->MREST_DEBUG_MODE );

    my $app = Web::Machine->new(
        resource => ( $class || 'Web::MREST::Dispatch' )
    )->to_app;

    my $test = Plack::Test->create( $app );
    isa_ok( $test, 'Plack::Test::MockHTTP' );
    return $test;

}


=head2 status_from_json

L<Web::MREST> is designed to return status objects in the HTTP response entity.
Before inclusion in the response, the status object is converted to JSON. This
routine goes the opposite direction, taking a JSON string and converting it
back into a status object.

FIXME: There may be some encoding issues here!

=cut

    my ( $json ) = @_;
    $log->debug( "Entering " . __PACKAGE__ . "::status_from_json" );
    my $obj;
    try {
        $obj = bless from_json( $json ), 'App::CELL::Status';
    } catch {
        $obj = $_;
    };
    return $obj if ref( $obj) eq 'App::CELL::Status';
    die "\n\nfrom_json died";
}


=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

    my ( $test, $code, $method, $resource, $json ) = validate_pos( @_, 1, 1, 1, 1, 0 );
    $log->debug( "Entering " . __PACKAGE__ . "::req" );

    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 @headers = (
        'accept' => 'application/json',
        'content-type' => 'application/json',
    );
    my $r = llreq( $method, $resource, \@headers, $json );

    # send request; get response
    my $res = $test->request( $r );
    isa_ok( $res, 'HTTP::Response' );
    diag( Dumper $res ) if ( $res->code == 500 );

    #diag( $res->code . " " . $res->message );
    is( $res->code, $code, "$method $resource" . ( $json ? " with $json" : "" ) . " 1" );
    my $content = $res->content;
    if ( $content ) {
        #diag( Dumper $content );
        is_valid_json( $content, "$method $resource" . ( $json ? " with $json" : "" ) . " 2" );
        my $status = status_from_json( $content );
        if ( my $location_header = $res->header( 'Location' ) ) {
            $status->{'location_header'} = $location_header;
        }
        return $status;
    }
    return;
}


=head2 llreq

Low-level request generator

=cut

    my ( $method, $uri, @args ) = @_;
    my ( $headers, $content );
    if ( @args ) {
        $headers = shift @args;
        $log->debug( "llreq: headers set to " . Dumper( $headers ) );
    } else {
        $headers = [
            'accept' => 'application/json',
            'content-type' => 'application/json',
        ];
    }
    if ( @args and defined( $args[0] ) ) {
        $log->debug( "llreq: args is " . Dumper( \@args ) );
        $content = join( ' ', @args );
    }
    return HTTP::Request->new( $method, $uri, $headers, $content );
}


=head2 docu_check

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

=cut

    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' resource
    my $status = req( $test, 200, 'demo', 'POST', '/docu', <<"EOH" );
{ "resource" : "$resource" }
EOH
    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', <<"EOH" );
{ "resource" : "$resource" }
EOH
    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 );
    }
}

1;