feat: add full Zonemaster stack with Docker and Spanish UI
- Clone all 5 Zonemaster component repos (LDNS, Engine, CLI, Backend, GUI) - Dockerfile.backend: 8-stage multi-stage build LDNS→Engine→CLI→Backend - Dockerfile.gui: Astro static build served via nginx - docker-compose.yml: backend (internal) + frontend (port 5353) - nginx.conf: root redirects to /es/, /api/ proxied to backend - zonemaster-gui/config.ts: defaultLanguage set to 'es' (Spanish) Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
494
zonemaster-engine/t/TestUtil/DSL/Compiler.pm
Normal file
494
zonemaster-engine/t/TestUtil/DSL/Compiler.pm
Normal file
@@ -0,0 +1,494 @@
|
||||
package TestUtil::DSL::Compiler;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use v5.24;
|
||||
|
||||
use Carp qw(croak confess);
|
||||
use Test::More ();
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
TestUtil::DSL::Compiler - compiler for the language defined in TestUtil::DSL
|
||||
|
||||
=cut
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 compile
|
||||
|
||||
Compiles the AST, obtained as a result of parsing an instance of the DSL, into
|
||||
a coderef that executes the tests defined in that DSL.
|
||||
|
||||
Set C<$TestUtil::DSL::Compiler::DEBUG> to a non-zero value in order to obtain
|
||||
debugging output. If running the corresponding C<.t> file in a harness, you
|
||||
may need to enable verbose output in order to see it (e.g. by passing C<-v>
|
||||
to C<prove>).
|
||||
|
||||
=cut
|
||||
|
||||
our $DEBUG = 0;
|
||||
|
||||
|
||||
sub compile {
|
||||
my ($ast) = @_;
|
||||
|
||||
confess unless exists $ast->{test_module};
|
||||
confess unless exists $ast->{test_case};
|
||||
|
||||
my $test_module = $ast->{test_module};
|
||||
my $test_case = $ast->{test_case};
|
||||
|
||||
my $test_method = sub {
|
||||
my ( $zone_name ) = @_;
|
||||
return Zonemaster::Engine->test_method(
|
||||
$test_module, $test_case, Zonemaster::Engine->zone( $zone_name ));
|
||||
};
|
||||
|
||||
my $func_preamble = _compile_preamble($ast);
|
||||
my $func_select_subtests = _compile_select_subtests($ast);
|
||||
my @compiled_ops = _compile_ops($ast->{ops}, $test_case, $test_method);
|
||||
|
||||
my $datafile = 't/' . File::Basename::basename( $0, '.t' ) . '.data';
|
||||
|
||||
return sub {
|
||||
my $context = {};
|
||||
|
||||
if ($DEBUG) {
|
||||
Test::More::note("Dumping AST read after parsing DSL:");
|
||||
Test::More::note(Test::More::explain($ast));
|
||||
}
|
||||
|
||||
$func_preamble->();
|
||||
|
||||
$context->{todo_tests} = [];
|
||||
$context->{disabled_tests} = [];
|
||||
$context->{selected_subtests} = $func_select_subtests->(
|
||||
$ENV{ZONEMASTER_SELECTED_SCENARIOS},
|
||||
$ENV{ZONEMASTER_DISABLED_SCENARIOS});
|
||||
|
||||
if ( not $ENV{ZONEMASTER_RECORD} ) {
|
||||
Test::More::note "Loading data file: $datafile";
|
||||
die q{Stored data file missing} if not -r $datafile;
|
||||
Zonemaster::Engine::Nameserver->restore( $datafile );
|
||||
Test::More::note "Done loading data file.";
|
||||
Zonemaster::Engine::Profile->effective->set( q{no_network} => 1 );
|
||||
}
|
||||
|
||||
Zonemaster::Engine::Profile->effective->merge(
|
||||
Zonemaster::Engine::Profile->from_json( qq({ "test_cases": ["$test_case"] }) ));
|
||||
|
||||
foreach my $callback ( @compiled_ops ) {
|
||||
$callback->($context);
|
||||
}
|
||||
|
||||
Test::More::done_testing();
|
||||
|
||||
if (scalar @{$context->{todo_tests}}) {
|
||||
Test::More::diag("The following scenarios are marked as TODO:\n");
|
||||
Test::More::diag(" $_") foreach @{$context->{todo_tests}};
|
||||
}
|
||||
if (scalar @{$context->{disabled_tests}}) {
|
||||
Test::More::diag("The following scenarios were not run:\n");
|
||||
Test::More::diag(" $_") foreach @{$context->{disabled_tests}};
|
||||
}
|
||||
|
||||
if ( $ENV{ZONEMASTER_RECORD} ) {
|
||||
Test::More::note "Saving data file: $datafile";
|
||||
Zonemaster::Engine::Nameserver->save( $datafile );
|
||||
Test::More::note "Done saving data file.";
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
# Top-level compilation helper functions
|
||||
|
||||
sub _compile_preamble {
|
||||
my ($ast) = @_;
|
||||
|
||||
confess unless exists $ast->{test_module};
|
||||
|
||||
my $testmod = q{Zonemaster::Engine::Test::} . $ast->{test_module};
|
||||
|
||||
return sub {
|
||||
Test::More::use_ok( q{Zonemaster::Engine::Nameserver} );
|
||||
Test::More::use_ok( $testmod );
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_root_hints {
|
||||
my ( $root_hints ) = @_;
|
||||
|
||||
return sub {
|
||||
Zonemaster::Engine::Recursor->remove_fake_addresses( '.' );
|
||||
Zonemaster::Engine::Recursor->add_fake_addresses( '.', $root_hints );
|
||||
Zonemaster::Engine::Recursor::clear_cache();
|
||||
}
|
||||
}
|
||||
|
||||
sub _compile_clear_cache {
|
||||
return sub {
|
||||
Zonemaster::Engine::Recursor::clear_cache();
|
||||
}
|
||||
}
|
||||
|
||||
sub _compile_select_subtests {
|
||||
my ($ast) = @_;
|
||||
|
||||
return sub {
|
||||
my ( $selected_scenarios, $disabled_scenarios ) = @_;
|
||||
|
||||
# Make a copy so as not to clobber the AST
|
||||
my %scenario_status = ( %{$ast->{scenario_status}} );
|
||||
|
||||
# Force the listed tests in $selected_scenarios to run as if their
|
||||
# status was testable.
|
||||
if ( defined $selected_scenarios ) {
|
||||
%scenario_status = map {
|
||||
$_ => [ 'skip', 'not selected by environment variable' ]
|
||||
} ( keys %scenario_status );
|
||||
foreach my $name ( split(/, */, $selected_scenarios) ) {
|
||||
croak "$name: no such scenario" unless exists $scenario_status{$name};
|
||||
$scenario_status{$name} = [ 'testable' ];
|
||||
}
|
||||
}
|
||||
|
||||
# Skip the tests explicitly listed in $disabled_scenarios
|
||||
foreach my $to_disable ( split(/, */, $disabled_scenarios // "") ) {
|
||||
croak "$to_disable: no such scenario" unless exists $scenario_status{$to_disable};
|
||||
$scenario_status{$to_disable} =
|
||||
[ 'skip', 'disabled by environment variable' ];
|
||||
}
|
||||
|
||||
return \%scenario_status;
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_ops {
|
||||
my ( $ops, $test_case, $test_method ) = @_;
|
||||
|
||||
return map {
|
||||
my ( $type, @args ) = @$_;
|
||||
if ( $type eq 'root_hints' ) {
|
||||
_compile_root_hints( @args );
|
||||
}
|
||||
elsif ( $type eq 'scenario' ) {
|
||||
_compile_run_scenario_block( @args, $test_case, $test_method );
|
||||
}
|
||||
elsif ( $type eq 'clear_cache' ) {
|
||||
_compile_clear_cache();
|
||||
}
|
||||
} @$ops;
|
||||
}
|
||||
|
||||
sub _compile_run_scenario_block {
|
||||
my ( $scenario_block, $test_case, $test_method ) = @_;
|
||||
|
||||
# Compiling a scenario block is a bit tricky because determining which
|
||||
# scenarios to run is done at runtime. We can’t just compile the scenario
|
||||
# block to a sub directly and be done with it; we need to wrap it into a
|
||||
# bit of code that checks if the scenario was forcibly enabled or disabled
|
||||
# in the environment before making the decision to run it or not.
|
||||
my $compiled_scenarios = _compile_scenario_block( $scenario_block, $test_case, $test_method );
|
||||
|
||||
my ($file, $line) = @{$compiled_scenarios->{caller}};
|
||||
my $callback = $compiled_scenarios->{callback};
|
||||
|
||||
return sub {
|
||||
my ( $context ) = @_;
|
||||
|
||||
my $selected_subtests = $context->{selected_subtests};
|
||||
my $disabled_tests = $context->{disabled_tests};
|
||||
my $todo_tests = $context->{todo_tests};
|
||||
|
||||
foreach my $descriptor (@{$compiled_scenarios->{args}}) {
|
||||
my $name = $descriptor->{scenario_name};
|
||||
my $zone_name = $descriptor->{zone_name};
|
||||
|
||||
my ( $status, $reason ) = @{$selected_subtests->{$name}};
|
||||
my $name_and_reason = "$name" . (defined $reason ? " ($reason)" : "");
|
||||
|
||||
if ( $status eq 'skip' ) {
|
||||
Test::More->builder->skip( $name_and_reason );
|
||||
push @$disabled_tests, $name_and_reason;
|
||||
next;
|
||||
}
|
||||
elsif ( $status eq 'not_testable' ) {
|
||||
Test::More->builder->todo_skip( $name_and_reason );
|
||||
push @$disabled_tests, $name_and_reason;
|
||||
next;
|
||||
}
|
||||
elsif ( $status eq 'todo' ) {
|
||||
# Avoid passing undef to Test::Builder::todo_start(), otherwise
|
||||
# older versions (e.g. the one shipped with Perl 5.26) will not
|
||||
# enable the todo status properly for the subtest if no reason
|
||||
# was provided for the todo keyword in the DSL.
|
||||
Test::More->builder->todo_start( $reason // "" );
|
||||
push @$todo_tests, $name_and_reason;
|
||||
}
|
||||
|
||||
my $ret = Test::More::subtest($name, $callback, $zone_name);
|
||||
# Test::More->builder->no_diag(1) was called inside the callback just before
|
||||
# exiting in order to suppress the default diag() output in case of failure
|
||||
# of the subtest. Be sure to re-enable it before continuing.
|
||||
Test::More->builder->no_diag(0);
|
||||
|
||||
if ( $status eq 'todo' ) {
|
||||
Test::More->builder->todo_end();
|
||||
}
|
||||
elsif ( $status eq 'testable' and not $ret ) {
|
||||
Test::More::diag(<<DIAG);
|
||||
Failed scenario '$name'
|
||||
at $file line $line.
|
||||
DIAG
|
||||
}
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_scenario_block {
|
||||
my ( $scenario_block, $test_case, $test_method ) = @_;
|
||||
|
||||
my @subtest_args = ();
|
||||
foreach my $name (@{$scenario_block->{names}}) {
|
||||
my $zone = lc _expand_template(
|
||||
$scenario_block->{body}{zone},
|
||||
SCENARIO => $name, TESTCASE => $test_case );
|
||||
|
||||
push @subtest_args, { scenario_name => $name, zone_name => $zone };
|
||||
}
|
||||
|
||||
return {
|
||||
caller => $scenario_block->{caller},
|
||||
callback => _compile_scenario_subtest( $scenario_block, $test_method ),
|
||||
args => \@subtest_args
|
||||
};
|
||||
}
|
||||
|
||||
# Scenario compilation helper functions
|
||||
|
||||
sub _compile_scenario_subtest {
|
||||
my ( $scenario_declaration, $test_method ) = @_;
|
||||
|
||||
my $func_add_fake_delegation = _compile_fake_ns( $scenario_declaration );
|
||||
my $func_add_fake_ds = _compile_fake_ds( $scenario_declaration );
|
||||
my @func_message_tests = _compile_message_tests( $scenario_declaration );
|
||||
|
||||
return sub {
|
||||
my ( $zone_name ) = @_;
|
||||
Test::More::plan(tests => scalar @func_message_tests + 1);
|
||||
|
||||
Test::More::note("Zone: $zone_name");
|
||||
$func_add_fake_delegation->($zone_name) if defined $func_add_fake_delegation;
|
||||
$func_add_fake_ds->($zone_name) if defined $func_add_fake_ds;
|
||||
|
||||
my @messages = $test_method->( $zone_name );
|
||||
|
||||
if ( my ( $error ) = grep { $_->tag eq 'MODULE_ERROR' } @messages ) {
|
||||
Test::More::fail("Test case executes without errors");
|
||||
Test::More::diag("Module died with the following error:\n " . $error->args->{"msg"});
|
||||
}
|
||||
else {
|
||||
Test::More::pass("Test case executes without errors");
|
||||
$_->( @messages ) foreach ( @func_message_tests );
|
||||
}
|
||||
|
||||
# At the end of a subtest, if there is at least one failure,
|
||||
# Test::More automatically generates a comment containing the location
|
||||
# of the failing test. This location is wrong, so we squelch any
|
||||
# diag() output. There is no other way than to call no_diag() here.
|
||||
Test::More->builder->no_diag(1);
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_fake_ns {
|
||||
my ( $scenario_declaration ) = @_;
|
||||
|
||||
if ( exists $scenario_declaration->{body}{fake_ns} ) {
|
||||
my $undel_ns = $scenario_declaration->{body}{fake_ns};
|
||||
return sub {
|
||||
my ( $zone_name ) = @_;
|
||||
# Use default value of "fill_in_empty_oob_glue".
|
||||
Zonemaster::Engine->add_fake_delegation(
|
||||
$zone_name => $undel_ns, fill_in_empty_oob_glue => 1 );
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _compile_fake_ds {
|
||||
my ( $scenario_declaration ) = @_;
|
||||
|
||||
if ( exists $scenario_declaration->{body}{fake_ds} ) {
|
||||
my @undel_ds = @{$scenario_declaration->{body}{fake_ds}};
|
||||
return sub {
|
||||
my ( $zone_name ) = @_;
|
||||
Zonemaster::Engine->add_fake_ds( $zone_name => $_ ) foreach @undel_ds;
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _compile_message_tests {
|
||||
my ( $scenario_declaration ) = @_;
|
||||
|
||||
map {
|
||||
my ( $type, $caller, $tag, %args ) = @$_;
|
||||
|
||||
if ( $type eq 'expect' and exists $args{code} ) {
|
||||
_compile_expect_with_code( $caller, $tag, $args{code} );
|
||||
}
|
||||
elsif ( $type eq 'expect' and exists $args{args} ) {
|
||||
_compile_expect_with_args( $caller, $tag, %{$args{args}} );
|
||||
}
|
||||
elsif ( $type eq 'expect' ) {
|
||||
_compile_expect_bare( $caller, $tag );
|
||||
}
|
||||
elsif ( $type eq 'forbid' ) {
|
||||
_compile_forbid( $caller, $tag );
|
||||
}
|
||||
} ( @{$scenario_declaration->{body}{message_tests}} );
|
||||
}
|
||||
|
||||
sub _compile_expect_bare {
|
||||
my ( $caller, $tag ) = @_;
|
||||
|
||||
return sub {
|
||||
_ok(
|
||||
scalar ( grep { $_->{tag} eq $tag } @_ ),
|
||||
"Tag '$tag' is outputted",
|
||||
$caller )
|
||||
or Test::More::diag("Tag '$tag' should have been outputted, but wasn't");
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_expect_with_args {
|
||||
my ( $caller, $tag, %args ) = @_;
|
||||
|
||||
my %predicates;
|
||||
my $explanation = "Looked for a message whose tag is '$tag'";
|
||||
my $where = "where";
|
||||
|
||||
foreach my $argument ( sort keys %args ) {
|
||||
$explanation .= "\n $where '$argument' ";
|
||||
$where = " and";
|
||||
|
||||
my $value = $args{$argument};
|
||||
my $comparison = do {
|
||||
if ( ref $value eq '' ) {
|
||||
$explanation .= "equals '$value'";
|
||||
sub { $_[0] eq $_[1] };
|
||||
}
|
||||
elsif ( ref $value eq 'Regexp' ) {
|
||||
$explanation .= "matches $value";
|
||||
sub { $_[0] =~ $_[1] };
|
||||
}
|
||||
elsif ( ref $value eq 'CODE' ) {
|
||||
$explanation .= "satisfies a custom predicate";
|
||||
sub { $_[1]->($_[0]) };
|
||||
}
|
||||
else {
|
||||
croak "Invalid argument value given to key '$argument'";
|
||||
}
|
||||
};
|
||||
$predicates{$argument} = sub {
|
||||
$comparison->($_->{args}{$argument}, $value)
|
||||
};
|
||||
}
|
||||
|
||||
$explanation .= "\n and contains no argument other than those listed above";
|
||||
|
||||
my $combined_predicate = sub {
|
||||
foreach my $k ( keys %{$_->{args}} ) {
|
||||
if ( exists $predicates{$k} ) {
|
||||
return 0 unless $predicates{$k}->($_);
|
||||
}
|
||||
else {
|
||||
# The message contains an argument that isn’t matched by anything
|
||||
# from the 'expect' keyword, so we fail the test for this message.
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
};
|
||||
|
||||
return sub {
|
||||
my @messages = grep { $_->{tag} eq $tag } @_;
|
||||
_ok(
|
||||
scalar ( grep { $combined_predicate->($_) } @messages ),
|
||||
"Messages of tag '$tag' exist with specified arguments",
|
||||
$caller )
|
||||
or do {
|
||||
Test::More::diag($explanation);
|
||||
Test::More::diag("Here are all messages that unsuccessfully matched:");
|
||||
Test::More::diag(" $_->{tag} " . $_->argstr) foreach ( @messages );
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_expect_with_code {
|
||||
my ( $caller, $tag, $code ) = @_;
|
||||
|
||||
return sub {
|
||||
my @messages_of_tag = grep { $_->{tag} eq $tag } @_;
|
||||
_ok(
|
||||
$code->( @messages_of_tag ),
|
||||
"Messages of tag '$tag' satisfy custom callback",
|
||||
$caller );
|
||||
};
|
||||
}
|
||||
|
||||
sub _compile_forbid {
|
||||
my ( $caller, $tag ) = @_;
|
||||
|
||||
return sub {
|
||||
_ok(
|
||||
! scalar ( grep { $_->{tag} eq $tag } @_ ),
|
||||
"Tag '$tag' is not outputted",
|
||||
$caller )
|
||||
or Test::More::diag("Tag '$tag' shouldn't have been outputted, but it was");
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
# Miscellaneous utilities
|
||||
|
||||
sub _expand_template {
|
||||
my ($template, %variables) = @_;
|
||||
|
||||
confess unless defined $template;
|
||||
|
||||
my $result = $template;
|
||||
for my $k (keys %variables) {
|
||||
$result =~ s/\{$k\}/$variables{$k}/g;
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
# A version of Test::More::ok that prints the correct location when a test fails.
|
||||
|
||||
sub _ok {
|
||||
my ( $ok, $test_name, $caller ) = @_;
|
||||
my ( $file, $line ) = @$caller;
|
||||
|
||||
# This is the only way to squelch the automatic diagnostics that are printed
|
||||
# on the TAP output when ok() fails. The TAP output erroneously points to
|
||||
# a line in t/TestUtil/DSL/Compiler.pm when an error occurs.
|
||||
Test::More->builder->no_diag(1);
|
||||
my $ret = Test::More::ok( $ok, $test_name );
|
||||
Test::More->builder->no_diag(0);
|
||||
|
||||
unless ( $ok ) {
|
||||
Test::More::diag(<<DIAG);
|
||||
Failed test '$test_name'
|
||||
at $file line $line.
|
||||
DIAG
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user