mirror of
https://gitlab.com/davical-project/davical.git
synced 2026-01-27 00:33:34 +00:00
569b20d92f
Written to provide scope for Apache2 config overrides as well (I think I'll need these to add Kerberos testing...)
646 lines
15 KiB
Perl
Executable File
646 lines
15 KiB
Perl
Executable File
#!/usr/bin/perl -w
|
|
#
|
|
# Run a test
|
|
#
|
|
|
|
use strict;
|
|
use warnings;
|
|
use open qw( :encoding(UTF-8) :std );
|
|
use File::Copy;
|
|
|
|
use DBI;
|
|
use Getopt::Long qw(:config permute); # allow mixed args.
|
|
use File::pushd;
|
|
|
|
# Options variables
|
|
my $debug = 0;
|
|
my $dsn = "davical";
|
|
my $dbuser = "";
|
|
my $dbpass = "";
|
|
my $webhost = 'mycaldav';
|
|
my $althost = 'myempty';
|
|
my $ldaphost = 'mycaldav_ldap';
|
|
my $testdef;
|
|
my $suite;
|
|
my $case;
|
|
my $helpmeplease = 0;
|
|
my $testmode = 'DAVICAL';
|
|
my $save_location = "/var/log/davical";
|
|
my $request_id;
|
|
|
|
# Hash for eval'd Perl code to store long lived variables in
|
|
my %evaled;
|
|
|
|
my $dbadir = $0;
|
|
$dbadir =~ s{/[^/]*$}{};
|
|
my $patchdir = $dbadir . "/patches";
|
|
|
|
|
|
GetOptions ('debug!' => \$debug,
|
|
'dsn=s' => \$dsn,
|
|
'dbuser=s' => \$dbuser,
|
|
'dbpass=s' => \$dbpass,
|
|
'webhost=s' => \$webhost,
|
|
'althost=s' => \$althost,
|
|
'test=s' => \$testdef,
|
|
'suite=s' => \$suite,
|
|
'case=s' => \$case,
|
|
'help' => \$helpmeplease );
|
|
|
|
usage() if ( $helpmeplease || ((!defined($suite) || !defined($case)) && !defined($testdef)));
|
|
|
|
my $dbh;
|
|
|
|
# Allow enabling debugging via an environment variable. Useful for debugging CI.
|
|
$debug = 1 if ($ENV{DEBUG} || 0) == 1;
|
|
|
|
my @arguments = ( "--basic", "--proxy", "", "--insecure" );
|
|
push @arguments, "--silent" unless ( $debug );
|
|
push @arguments, "--verbose" if ( $debug );
|
|
|
|
my $url;
|
|
my $script; # Not neede as global, used as flag.
|
|
my $script_dir;
|
|
my $is_head_request = 0;
|
|
my $sql_count = 1;
|
|
my @auth = ( "--user", "user1:user1" );
|
|
|
|
# Allow easier pasting of tests on the command line.
|
|
$case =~ s/\.test$//;
|
|
|
|
if ( ! defined($testdef) ) {
|
|
$testdef = "tests/$suite/$case.test";
|
|
}
|
|
|
|
die "You need to run this from the testing directory!\n"
|
|
unless -d "tests";
|
|
|
|
# Heuristics to work out if we should make $save_location elsewhere. We want
|
|
# /var/log/davical for the CI rig, but within the test directories for local
|
|
# runs. Do we?
|
|
if ($ENV{USER} ne 'testrunner') {
|
|
$save_location = "tests/$suite/results/";
|
|
} elsif (! -w $save_location) {
|
|
warn "$save_location isn't writable, using local location";
|
|
$save_location = "tests/$suite/results/";
|
|
}
|
|
|
|
# Record the request_ids from the web server.
|
|
my $request_id_file = "$save_location/$case.request_id";
|
|
open(my $REQUEST_ID_FILE, "> $request_id_file")
|
|
|| die "Failed to open $request_id_file for writing";
|
|
|
|
# Allow for application configuration per test file. Ensure the file we
|
|
# manage is empty in case the previous test was aborted.
|
|
my $dynamic_app_conf_file = 'regression-conf.php.dynamic.per-test';
|
|
if (-f $dynamic_app_conf_file) {
|
|
unlink $dynamic_app_conf_file
|
|
|| die "Failed to remove $dynamic_app_conf_file\n";
|
|
}
|
|
|
|
my $datafile = $testdef;
|
|
$datafile =~ s{\.test$}{};
|
|
push @arguments, "--header", 'X-DAViCal-Testcase: '.$datafile;
|
|
$datafile .= '.data';
|
|
|
|
my $state = "";
|
|
my $data_binary;
|
|
|
|
my $sql_variable = "";
|
|
my $sql_statement = "";
|
|
my $sql_values = {};
|
|
my $perl_code = "";
|
|
my $app_conf = "";
|
|
my $queries = ();
|
|
my $replacements = ();
|
|
my $line_number = 0;
|
|
|
|
|
|
open( TEST, '<', $testdef ) or die "Can't open '$testdef'";
|
|
while( <TEST> ) {
|
|
my $line = $_;
|
|
$line_number++;
|
|
|
|
# Do any variable replacements we have so far
|
|
foreach my $variable ( keys %{$sql_values} ) {
|
|
my $value = $sql_values->{$variable};
|
|
$line =~ s/##$variable##/$value/g;
|
|
}
|
|
|
|
if ( $state ne "" ) {
|
|
$line =~ /^BEGIN(?!:)/ && do {
|
|
print "Found a new BEGIN line, while still processing a previous one. Line number: $line_number\n";
|
|
exit 0;
|
|
};
|
|
|
|
if ( /^END$state$/ ) {
|
|
if ( $state eq "SQL" ) {
|
|
get_sql_value( $sql_variable, $sql_values, $sql_statement );
|
|
}
|
|
elsif ( $state eq "DOSQL" ) {
|
|
do_sql( $sql_statement );
|
|
}
|
|
elsif ( $state eq "QUERY" ) {
|
|
run_sql($sql_statement);
|
|
}
|
|
elsif ( $state eq "PERL" ) {
|
|
eval($perl_code);
|
|
if ($@) {
|
|
print "Failed to run Perl code: $@\n";
|
|
exit 0;
|
|
}
|
|
}
|
|
elsif ( $state eq "APPCONF" ) {
|
|
write_app_conf($app_conf);
|
|
}
|
|
$state = "";
|
|
}
|
|
elsif ( $state eq "DATA" ) {
|
|
$data_binary .= $line;
|
|
}
|
|
elsif ( $state =~ /^SQL|QUERY|DOSQL$/ ) {
|
|
$sql_statement .= $line;
|
|
}
|
|
elsif ( $state eq "PERL" ) {
|
|
$perl_code .= $line;
|
|
}
|
|
elsif ( $state eq "APPCONF" ) {
|
|
$app_conf .= $line;
|
|
}
|
|
next;
|
|
}
|
|
|
|
/^\s*(#|$)/ && next;
|
|
|
|
$line =~ /^\s*HEAD\s*(#|$|=)/ && do {
|
|
push @arguments, "--include";
|
|
};
|
|
|
|
$line =~ /^\s*MODE\s*=\s*(\S*)(?:,(\d+))/ && do {
|
|
my $mode = $1;
|
|
my $args = $2;
|
|
|
|
if (uc($mode) =~ /^TAP$/) {
|
|
$testmode = 'TAP';
|
|
use Test::More;
|
|
|
|
if ($args =~ /^\d+$/) {
|
|
plan tests => $args;
|
|
}
|
|
} else {
|
|
die "Unknown test mode: $1";
|
|
}
|
|
};
|
|
|
|
$line =~ /^\s*VERBOSE\s*(#|$|=)/ && do {
|
|
push @arguments, "--verbose";
|
|
};
|
|
|
|
$line =~ /^\s*NOAUTH\s*(#|$|=)/ && do {
|
|
@auth = ();
|
|
};
|
|
|
|
$line =~ /^\s*DIGEST\s*(#|$|=)/ && do {
|
|
push @arguments, "--digest";
|
|
@auth = ( "--user", $1 );
|
|
};
|
|
|
|
$line =~ /^\s*AUTH\s*=\s*(\S.*)$/ && do {
|
|
@auth = ( "--user", $1 );
|
|
};
|
|
|
|
$line =~ /^\s*DATA\s*=\s*(\S.*)$/ && do {
|
|
my $basename = $1;
|
|
if ( defined($suite) ) {
|
|
if ( -e "tests/$suite/$basename.data" ) {
|
|
$datafile="tests/$suite/$basename.data";
|
|
}
|
|
elsif ( -e "tests/$suite/$basename" ) {
|
|
$datafile="tests/$suite/$basename";
|
|
}
|
|
|
|
}
|
|
elsif ( -e "$basename.data" ) {
|
|
$datafile="$basename.data";
|
|
}
|
|
elsif ( -e $basename ) {
|
|
$datafile=$basename;
|
|
}
|
|
else {
|
|
die "Can't find DATA file $basename or $basename.data";
|
|
}
|
|
};
|
|
|
|
$line =~ /^BEGINDATA\s*$/ && do {
|
|
$data_binary = "";
|
|
$state = "DATA";
|
|
};
|
|
|
|
$line =~ /^BEGINPERL\s*$/ && do {
|
|
$perl_code = "";
|
|
$state = "PERL";
|
|
};
|
|
|
|
$line =~ /^BEGINAPPCONF\s*$/ && do {
|
|
$app_conf = "";
|
|
$state = "APPCONF";
|
|
};
|
|
|
|
$line =~ /^(?:BEGIN)?GETSQL\s*=\s*(\S.*)$/ && do {
|
|
$sql_variable = $1;
|
|
$sql_statement = "";
|
|
$state = "SQL";
|
|
};
|
|
|
|
$line =~ /^(?:BEGIN)?DOSQL\s*$/ && do {
|
|
$sql_statement = "";
|
|
$state = "DOSQL";
|
|
};
|
|
|
|
$line =~ /^\s*APPCONF\s*=\s*(\S.*)$/ && do {
|
|
my $basename = $1;
|
|
my $test_app_conf_file;
|
|
|
|
if ( -e "tests/$suite/$basename.appconf" ) {
|
|
$test_app_conf_file="tests/$suite/$basename.appconf";
|
|
}
|
|
elsif ( -e "tests/$suite/$basename" ) {
|
|
$test_app_conf_file="tests/$suite/$basename";
|
|
}
|
|
|
|
if (! defined $test_app_conf_file) {
|
|
die "Can't find app conf file $basename or $basename.appconf";
|
|
}
|
|
|
|
copy $test_app_conf_file, $dynamic_app_conf_file
|
|
|| die "Failed to copy $test_app_conf_file to $dynamic_app_conf_file: $!\n";
|
|
};
|
|
|
|
|
|
$line =~ /^REPLACE\s*=\s*(\S)(.*)$/ && do {
|
|
my $separator = $1;
|
|
$2 =~ /^([^$separator]*)$separator([^$separator]*)$separator$/ && do {
|
|
push @$replacements, { 'pattern' => $1, 'replacement' => $2 };
|
|
};
|
|
};
|
|
|
|
$line =~ /^(?:BEGIN)?QUERY\s*$/ && do {
|
|
$sql_statement = "";
|
|
$state = "QUERY";
|
|
};
|
|
|
|
$line =~ /^\s*TYPE\s*=\s*(\S.*)$/ && do {
|
|
if ( $1 eq "HEAD" ) {
|
|
push @arguments, "--head";
|
|
}
|
|
else {
|
|
push @arguments, "--request", $1;
|
|
}
|
|
};
|
|
|
|
# HTTP headers to send with curl
|
|
$line =~ /^\s*HEADER\s*=\s*(\S.*)$/ && do {
|
|
my $arg = $1;
|
|
$arg =~ s{regression.host}{$webhost};
|
|
$arg =~ s{regression_ldap.host}{$ldaphost};
|
|
$arg =~ s{alternate.host}{$althost};
|
|
push @arguments, "--header", $arg;
|
|
};
|
|
|
|
# URL to use with curl
|
|
$line =~ /^\s*URL\s*=\s*(\S.*)$/ && do {
|
|
$url = $1;
|
|
$url =~ s{regression.host}{$webhost};
|
|
$url =~ s{regression_ldap.host}{$ldaphost};
|
|
$url =~ s{alternate.host}{$althost};
|
|
|
|
run_curl($url);
|
|
};
|
|
|
|
|
|
# The directory to run the next SCRIPT in.
|
|
$line =~ /^\s*SCRIPT_DIR\s*=\s*(\S.*)$/ && do {
|
|
$script_dir = $1;
|
|
};
|
|
|
|
# Run this SCRIPT, collect the output.
|
|
$line =~ /^\s*SCRIPT\s*=\s*(\S.*)$/ && do {
|
|
$script=$1;
|
|
$script =~ s{regression.host}{$webhost};
|
|
$script =~ s{regression_ldap.host}{$ldaphost};
|
|
$script =~ s{alternate.host}{$althost};
|
|
|
|
my $dir = pushd($script_dir)
|
|
if defined $script_dir;
|
|
|
|
open RESULTS, "-|", $script;
|
|
while( <RESULTS> ) {
|
|
my $line = $_;
|
|
foreach my $replacement ( @$replacements ) {
|
|
$line =~ s/$replacement->{'pattern'}/$replacement->{'replacement'}/;
|
|
}
|
|
print $line;
|
|
}
|
|
|
|
$script_dir = undef;
|
|
};
|
|
|
|
$line =~ /^\s*STATIC\s*=\s*(.*?)\s*$/ && do {
|
|
my $source = "tests/$suite/static/$1";
|
|
my $dest = "../htdocs/testfiles";
|
|
|
|
die "Can't find $source to copy into $dest\n"
|
|
unless -f $source;
|
|
|
|
mkdir $dest
|
|
unless -d $dest;
|
|
|
|
copy($source, $dest)
|
|
|| die "Failed to copy $source: $1";
|
|
}
|
|
}
|
|
|
|
if ( ! defined $url && ! defined $script && ! defined $sql_statement
|
|
&& ! defined $perl_code ) {
|
|
print <<EOERROR ;
|
|
The .test file must contain either at least one URL, SCRIPT, PERL, or QUERY.
|
|
EOERROR
|
|
exit (2);
|
|
}
|
|
|
|
if ($testmode eq 'TAP') {
|
|
done_testing();
|
|
}
|
|
|
|
exit(0);
|
|
|
|
sub run_curl {
|
|
my $url = shift;
|
|
|
|
push @arguments, @auth;
|
|
|
|
if ( -f $datafile ) {
|
|
push @arguments, "--data-binary", "\@$datafile";
|
|
}
|
|
elsif ( defined($data_binary) ) {
|
|
push @arguments, "--data-binary", $data_binary;
|
|
}
|
|
else {
|
|
undef($datafile);
|
|
}
|
|
|
|
push @arguments, $url;
|
|
|
|
warn join " ", "curl", @arguments, "\n"
|
|
if $debug;
|
|
|
|
open RESULTS, "-|", "curl", @arguments;
|
|
while ( <RESULTS> ) {
|
|
my $line = $_;
|
|
|
|
# Grab the web server request_id for later reference
|
|
if ($line =~ /^Request-ID: (.*?)$/) {
|
|
$ENV{REQUEST_ID} = $1;
|
|
$request_id = $1;
|
|
print $REQUEST_ID_FILE "$1\n";
|
|
}
|
|
|
|
foreach my $replacement ( @$replacements ) {
|
|
$line =~ s/$replacement->{'pattern'}/$replacement->{'replacement'}/;
|
|
}
|
|
|
|
print $line;
|
|
}
|
|
|
|
print "\n";
|
|
}
|
|
|
|
sub run_sql {
|
|
my $query = shift;
|
|
|
|
print "SQL Query " . $sql_count++ . " Result:\n";
|
|
|
|
opendb() unless defined($dbh);
|
|
|
|
# run SQL statement and dump results, into array of hashes
|
|
my $results = $dbh->selectall_arrayref($sql_statement, { Slice => {} } );
|
|
|
|
if ( $dbh->err ) {
|
|
print $dbh->errstr, "\n";
|
|
return;
|
|
} elsif (! defined $results) {
|
|
print "No results from SQL query\n";
|
|
return;
|
|
}
|
|
|
|
foreach my $row ( @$results ) {
|
|
warn "Query result ================================================\n"
|
|
if $debug;
|
|
my $sep = "";
|
|
foreach my $name ( sort keys %$row ) {
|
|
my $value = $row->{$name};
|
|
$value = 'NULL' unless ( defined($value) );
|
|
printf("%17.17s: >%s<\n", $name, $value );
|
|
}
|
|
print "\n";
|
|
}
|
|
}
|
|
|
|
|
|
|
|
=item do_sql( $sql_statement )
|
|
|
|
Queries the database using the specified statement and
|
|
ignores the result.
|
|
|
|
=cut
|
|
|
|
sub do_sql {
|
|
my $sql = shift;
|
|
|
|
opendb() unless defined($dbh);
|
|
$dbh->do($sql);
|
|
|
|
if ( $dbh->err ) {
|
|
print $dbh->errstr, "\n";
|
|
return;
|
|
}
|
|
|
|
print "SQL executed successfully.\n";
|
|
print $sql, "\n";
|
|
}
|
|
|
|
|
|
=item get_sql_value( $sql_variable, $sql_values, $sql_statement )
|
|
|
|
Queries the database using the specified statement and puts
|
|
the first column of the first row returned into the
|
|
hash referenced $sql_values->{$sql_variable} for replacement
|
|
later in the parsing process.
|
|
|
|
=cut
|
|
|
|
sub get_sql_value {
|
|
my $varname = shift;
|
|
my $values = shift;
|
|
my $sql = shift;
|
|
|
|
opendb() unless defined($dbh);
|
|
my $results = $dbh->selectall_arrayref($sql);
|
|
|
|
if ( $dbh->err ) {
|
|
print $dbh->errstr, "\n";
|
|
return;
|
|
}
|
|
|
|
warn "RESULT for $varname is ", $results->[0][0], "\n"
|
|
if $debug;
|
|
|
|
$values->{$varname} = (defined($results->[0][0]) ? $results->[0][0] : "");
|
|
}
|
|
|
|
=item opendb()
|
|
|
|
Opens the database connection to the global $dbh handle.
|
|
Note that the standard PostgreSQL environment variables will also work
|
|
with DBD::Pg.
|
|
|
|
=cut
|
|
|
|
sub opendb {
|
|
$dsn = "dbi:Pg:dbname=$dsn";
|
|
$dbh = DBI->connect($dsn, $dbuser, $dbpass, { AutoCommit => 1 } ) or die "Can't connect to database $dsn";
|
|
$dbh->do("SET TIMEZONE TO 'Pacific/Auckland'");
|
|
}
|
|
|
|
sub webui_login {
|
|
my %args = (
|
|
username => undef,
|
|
password => undef,
|
|
url => undef,
|
|
failauth => 0,
|
|
@_,
|
|
);
|
|
|
|
use Test::WWW::Mechanize;
|
|
my $mech = Test::WWW::Mechanize->new;
|
|
|
|
$mech->get_ok($args{url}, "Fetch first page");
|
|
$mech->text_contains('Log On Please', "Not logged in");
|
|
$mech->submit_form_ok(
|
|
{
|
|
fields => {
|
|
username => $args{username},
|
|
password => $args{password},
|
|
},
|
|
}, "Login to site"
|
|
);
|
|
|
|
if ($args{failauth}) {
|
|
# We expected failure.
|
|
$mech->text_contains("You must log in to use this system", "Failed to login");
|
|
} else {
|
|
$mech->text_contains("You are logged on as " . $args{username}, "Logged in");
|
|
}
|
|
|
|
return $mech;
|
|
}
|
|
|
|
=item write_app_conf()
|
|
|
|
Write per test configuration entries to the DAViCal regression test server
|
|
configuration.
|
|
|
|
=cut
|
|
|
|
sub write_app_conf {
|
|
my $content = shift;
|
|
|
|
# We may wany to append extra content to a common file.
|
|
open(my $FILE, ">> $dynamic_app_conf_file")
|
|
|| die "Failed to open $dynamic_app_conf_file for writing";
|
|
print $FILE $content;
|
|
}
|
|
|
|
|
|
sub usage {
|
|
print <<EOERROR ;
|
|
|
|
Usage:
|
|
dav_test [DB opts] [--suite <testsuite> --case <testname>] | [--test <filename>]
|
|
|
|
This program will read the file 'tests/<testsuite>/<testname>.test
|
|
and follow the instructions there.
|
|
|
|
The following options are available for controlling the database, for
|
|
those test cases which might require it:
|
|
--dsn <database>[;port=NNNN][;host=example.com]
|
|
--dbuser <user>
|
|
--dbpass <password>
|
|
|
|
|
|
The test instructions will include lines defining the test like:
|
|
=================================================
|
|
# This is an example
|
|
HEADER=Depth: 0
|
|
HEADER=Content-type: text/xml
|
|
TYPE=PROPFIND
|
|
|
|
HEAD
|
|
|
|
DATA=OTHERTEST
|
|
|
|
URL=http://mycaldav/caldav.php/andrew/
|
|
|
|
# This will let you use ##somename## for this value after this
|
|
GETSQL=somename
|
|
SELECT column FROM table WHERE criteria
|
|
ENDSQL
|
|
|
|
# The data can be included in line
|
|
BEGINDATA
|
|
... data content ...
|
|
ENDDATA
|
|
|
|
# The result could be some SQL output
|
|
QUERY
|
|
SELECT something, or, other FROM table ...
|
|
ENDQUERY
|
|
|
|
# Run some Perl code
|
|
BEGINPERL
|
|
my \$variable = 'foo';
|
|
ENDPERL
|
|
|
|
# Dynamically add content to the DAViCal configuration file for this test.
|
|
# Allows ad-hoc config changes for tests. See also APPCONF. If APPCONF isn't
|
|
# used, then you must start this with "<?php" as below. If APPCONF is used,
|
|
# then it must start with "<?php".
|
|
BEGINAPPCONF
|
|
<?php
|
|
|
|
\$valid_php = "in here";
|
|
ENDAPPCONF
|
|
|
|
REPLACE=/pattern/replacement/
|
|
=================================================
|
|
|
|
URL The URL to request from (request is sent when seen).
|
|
HEADER An additional header for the request
|
|
TYPE The type of request (e.g. GET/PUT/POST/REPORT/...)
|
|
HEAD Whether to include the headers in the recorded response
|
|
VERBOSE Whether to provide the full request / response headers.
|
|
DATA The name of a different test in this suite to use data from.
|
|
REPLACE A perl regex replacement to post-process the result through.
|
|
APPCONF A file that will be insert into the DAViCal config file. This is
|
|
inserted first, before any content in BEGINAPPCONF/ENDAPPCONF to
|
|
allow a common config file for a set of tests, but also to allow
|
|
for individual test overrides.
|
|
|
|
Additionally, if a file 'tests/<testsuite>/<testname>.data' exists
|
|
the contents of that file will be sent in the body of the request.
|
|
|
|
EOERROR
|
|
exit(1);
|
|
}
|