stunnel4/debian/tests/runtime.pl
2017-11-15 15:03:25 +01:00

648 lines
16 KiB
Perl
Executable File

#!/usr/bin/perl
use v5.14;
use strict;
use warnings;
use AnyEvent;
use AnyEvent::Handle;
use AnyEvent::Socket qw(tcp_connect tcp_server);
use AnyEvent::Util qw(portable_socketpair);
use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC);
use IO::Handle;
use Path::Tiny 0.097;
use POSIX qw(WNOHANG);
use Socket;
# AnyEvent's TLS support seems to require this...
use threads;
my %children;
my $child_reaper_w;
my $greeting = 'Well hello there!';
sub reap_leftover_children();
sub child_reaper();
sub register_child_reaper()
{
$child_reaper_w = AnyEvent->signal(
signal => 'CHLD',
cb => \&child_reaper,
);
$SIG{__DIE__} = sub {
my ($msg) = @_;
warn "__DIE__ handler invoked: ".($msg =~ s/[\r\n]*$//sr)."\n";
reap_leftover_children;
};
}
sub unregister_child_reaper()
{
undef $child_reaper_w;
}
sub child_reaper()
{
while (1) {
my $pid = waitpid -1, WNOHANG;
my $status = $?;
if (!defined $pid) {
die "Could not waitpid() in a SIGCHLD handler: $!\n";
} elsif ($pid == 0 || $pid == -1) {
last;
} else {
$children{$pid}{cv} //= AnyEvent->condvar;
$children{$pid}{cv}->send($status);
}
}
}
sub register_child($ $)
{
my ($pid, $desc) = @_;
# Weird, but we want it to be at least reasonably atomic-like
$children{$pid}{cv} //= AnyEvent->condvar;
my $ch = $children{$pid};
$ch->{pid} = $pid;
$ch->{desc} = $desc;
}
sub dump_children()
{
join '', map {
my $ch = $children{$_};
"\t$ch->{pid}\t".
($ch->{cv}->ready
? $ch->{cv}->recv
: '(none)'
).
"\t$ch->{desc}\n"
} sort { $a <=> $b } keys %children
}
sub wait_for_child($)
{
my ($pid) = @_;
if (!defined $children{$pid}) {
die "Internal error: wait_for_child() invoked for ".
"unregistered pid $pid\n".dump_children;
}
my $status = $children{$pid}{cv}->recv;
delete $children{$pid};
return $status;
}
sub reap_leftover_children()
{
say 'Oof, let us see if there are any children left';
if (!%children) {
say 'Everyone has been accounted for; great!';
return;
}
for my $pid (keys %children) {
my $ch = $children{$pid};
if ($ch->{cv}->ready) {
my $status = wait_for_child $pid;
say "Hm, child $pid seems to have finished already, status $status";
}
}
if (!%children) {
say 'Everyone has actually been accounted for; great!';
return;
}
for my $pid (keys %children) {
say "Pffth, sending a SIGKILL to $pid";
kill 'KILL', $pid;
}
for my $pid (keys %children) {
my $ch = $children{$pid};
if ($ch->{cv}->ready) {
wait_for_child $pid;
say "OK, $pid done";
}
}
# Bah, figure out some way to let the loop run even if we're within the loop...
if (%children) {
say 'Some children remaining, laying low for a second...';
sleep 1;
for my $pid (keys %children) {
say "- waiting for $pid ($children{$pid}{desc})";
wait_for_child $pid;
say "- OK, $pid done";
}
}
if (%children) {
say 'Something really weird happened, why are there still children around?';
say dump_children;
}
}
sub close_on_exec($ $)
{
my ($fh, $close) = @_;
my $flags = fcntl $fh, F_GETFD, 0 or
die "Could not obtain a file descriptor's flags: $!\n";
my $nflags = $close
? ($flags | FD_CLOEXEC)
: ($flags & ~FD_CLOEXEC);
fcntl $fh, F_SETFD, $nflags or
die "Could not set a file descriptor's flags: $!\n";
}
sub anyevent_socketpair($)
{
my ($name) = @_;
my ($fh1, $fh2) = portable_socketpair;
if (!defined $fh1) {
die "Could not create the $name socketpair: $!\n";
}
$fh1->autoflush(1);
$fh2->autoflush(1);
return (AnyEvent::Handle->new(fh => $fh1), AnyEvent::Handle->new(fh => $fh2));
}
sub find_listening_port($ $ $ $ $)
{
my ($address, $port_start, $step, $count, $cb) = @_;
my $res;
my $port = $port_start;
for (1..$count) {
eval {
$res = tcp_server $address, $port, $cb;
};
last if $res;
say "Could not listen on $address:$port: $@";
$port += $step;
}
if (!defined $res) {
die "Could not find a listening port on $address\n";
}
return ($port, $res);
}
my %conns;
sub register_client_connection($)
{
my ($fh) = @_;
my $sockaddr = getsockname $fh;
if (!defined $sockaddr) {
die "Could not obtain the local address of the just-connected socket: $!\n";
}
my ($port, $addr_num) = sockaddr_in $sockaddr;
if (!defined $port || !defined $addr_num) {
die "Could not decode the address and port from a sockaddr_in structure: $!\n";
}
my $addr = inet_ntoa $addr_num;
if (!defined $addr) {
die "Could not decode a numeric address: $!\n";
}
my $id = "$addr:$port";
$conns{$id}{cv} //= AnyEvent->condvar;
$conns{$id}{fh} //= $fh;
return $id;
}
sub await_client_connection($ $; $)
{
my ($lis_main, $cv, $skip_register) = @_;
my $die = sub {
warn "@_";
$cv->send(undef);
};
$lis_main->rtimeout(10);
$lis_main->on_rtimeout(sub { $die->("The listener's accept message timed out\n") });
$lis_main->push_read(line => sub {
my ($handle, $line) = @_;
if ($line !~ m{^ accept \s+ (?<id> \S+ ) $}x) {
return $die->("The accept server did not send an 'accept' message: $line\n");
}
my ($id) = $+{id};
$conns{$id}{cv} //= AnyEvent->condvar unless $skip_register;
$lis_main->rtimeout(10);
$lis_main->on_rtimeout(sub { $die->("The listener's close message timed out\n") });
$lis_main->push_read(line => sub {
my ($handle, $line) = @_;
if ($line !~ m{^ close \s+ (?<id> \S+ ) $}x) {
return $die->("The accept server did not send an 'close' message: $line\n");
}
my ($cid) = $+{id};
if ($cid ne $id) {
return $die->("The accept server's 'close' message had id '$cid' instead of the accepted one '$id'\n");
}
$lis_main->rtimeout(0);
$cv->send($id);
});
});
}
sub adopt_client_connection($ $)
{
my ($id, $opts) = @_;
my $w;
my $do_close = sub {
my ($err) = @_;
$w->push_shutdown;
$w->destroy;
undef $w;
undef $conns{$id}{handle};
#close $conns{$id}{fh};
if (defined $err) {
warn "$err\n";
$conns{$id}{cv}->send(undef);
} else {
$conns{$id}{cv}->send(1);
}
};
$w = AnyEvent::Handle->new(
fh => $conns{$id}{fh},
%{$opts}, # TLS or something?
on_error => sub {
my ($handle, $fatal, $message) = @_;
if (!$fatal) {
warn "A non-fatal error occurred reading from the $id connection: $message\n";
} else {
$do_close->("A fatal error occurred reading from the $id connection: $message");
}
},
rtimeout => 10,
on_rtimeout => sub {
$do_close->("Reading from the $id connection timed out");
},
);
$w->push_read(line => sub {
my ($handle, $line) = @_;
$w->rtimeout(0);
if ($line ne $greeting) {
$do_close->("The $id connection sent us a line that was not the greeting: expected '$greeting', got '$line'");
} else {
$do_close->(undef);
}
});
$conns{$id}{handle} = $w;
}
sub client_connect($ $ $)
{
my ($address, $port, $cv) = @_;
return tcp_connect $address, $port, sub {
my ($fh) = @_;
if (!defined $fh) {
die "Could not connect to the cleartext listening socket on $address:$port: $!\n";
}
my $id = register_client_connection $fh;
say "Connected to $address:$port, local $id";
$cv->send($id);
adopt_client_connection($id, {});
};
}
MAIN:
{
my $stunnel = $ENV{TEST_STUNNEL} // 'stunnel4';
my $test_done = AnyEvent->condvar;
my ($certsdir, $certfile, $keyfile);
for my $name (qw(certs debian/tests/certs)) {
my $dir = path($name);
if (-d $dir) {
$certfile = $dir->child('certificate.pem');
$keyfile = $dir->child('key.pem');
if (-f $certfile && -f $keyfile) {
$certsdir = path($dir);
last;
}
}
}
die "Could not locate the test certificates directory\n" unless defined $certsdir;
say "Found the certificate at $certfile and the private key at $keyfile";
my $tempdir = Path::Tiny->tempdir;
say "Using the $tempdir temporary directory";
register_child_reaper;
{
say 'About to get the stunnel version information';
pipe my $s_in, my $s_out or die "Could not create an fd pair: $!\n";
close_on_exec $s_in, 0;
close_on_exec $s_out, 0;
my $pid = fork;
if (!defined $pid) {
die "Could not fork for stunnel: $!\n";
} elsif ($pid == 0) {
open STDERR, '>&', $s_out or
die "Could not reopen stderr in the child process: $!\n";
close STDIN or
die "Could not close stdin in the child process: $!\n";
close STDOUT or
die "Could not close stdout in the child process: $!\n";
close $s_in or
die "Could not close the reader fd in the child process: $!\n";
exec $stunnel, '-version';
die "Could not execute '$stunnel': $!\n";
}
register_child $pid, "$stunnel -version";
close $s_out or
die "Could not close the writer fd in the parent process: $!\n";
my ($got_version, $before_version) = (undef, '');
my $eof = AnyEvent->condvar;
my $f_out = AnyEvent->io(
fh => $s_in,
poll => 'r',
cb => sub {
my $line = <$s_in>;
if (!defined $line) {
$eof->send($got_version);
} elsif (!$got_version) {
if ($line =~ m{^
stunnel \s+
(?<version> \d+ \. \S+)
\s+ on \s+
}x) {
$got_version = $+{version};
} else {
$before_version .= $line;
}
}
});
$eof->recv;
if ($before_version ne '') {
warn "stunnel produced output before the version number:\n$before_version\n";
}
if (!defined $got_version) {
die "Could not get the stunnel version number\n";
}
say "Got stunnel version $got_version";
my $status = wait_for_child $pid;
if ($status != 0) {
die "stunnel -version did not exit successfully, status $status\n";
}
}
my ($lis_listener, $lis_main) = anyevent_socketpair 'listener';
my $listen_address = '127.0.0.1';
my %listen_clear_conns;
my ($listen_clear_port, $listen_clear) = find_listening_port $listen_address, 6502, 200, 100, sub {
my ($fh, $host, $port) = @_;
my $id = "$host:$port";
say "Accepted a connection from $id";
$lis_listener->push_write("accept $id\n");
my $w;
my $do_close = sub {
$w->destroy;
delete $listen_clear_conns{$id};
};
$w = AnyEvent::Handle->new(
fh => $fh,
on_error => sub {
my ($handle, $fatal, $message) = @_;
warn "A ".($fatal ? 'fatal' : 'non-fatal').
"error occurred writing to the $id connection: $message\n";
$do_close->();
},
timeout => 10,
on_timeout => sub {
my ($handle) = @_;
warn "Writing to the $id connection timed out\n";
$do_close->();
},
on_read => sub {
my ($handle) = @_;
warn "The $id connection sent data to the server?!\n";
$do_close->();
},
on_eof => sub {
my ($handle) = @_;
say "Got an eof from $id, all seems well";
$do_close->();
$lis_listener->push_write("close $id\n");
},
);
$w->push_write("$greeting\n");
$w->push_shutdown;
$listen_clear_conns{$id} = $w;
};
say "Listening for cleartext connections on $listen_address:$listen_clear_port";
{
my $listener_test_id_cv = AnyEvent->condvar;
my $check_listen_clear = client_connect $listen_address, $listen_clear_port, $listener_test_id_cv;
my $id = $listener_test_id_cv->recv;
if (!defined $id) {
die "Could not connect to the cleartext server\n";
}
say "Got a local connection id $id";
my $listener_test_done = AnyEvent->condvar;
await_client_connection $lis_main, $listener_test_done;
say 'Waiting for the server to acknowledge a completed client connection';
my $sid = $listener_test_done->recv;
if (!defined $sid) {
die "The listener did not acknowledge the connection\n";
} elsif ($sid ne $id) {
die "The listener did not acknowledge the same connection: expected '$id', got '$sid'\n";
}
say 'Waiting for the client connection itself to report completion';
my $res = $conns{$id}{cv}->recv;
if (!defined $res) {
die "The client connection did not complete the chat with the cleartext server\n";
}
say 'Looks like we are done with the test cleartext connection!';
}
my $st_server_port;
{
my $dummy;
($st_server_port, $dummy) = find_listening_port $listen_address, 8086, 200, 100, sub {
my ($fh) = @_;
say "Eh, we really didn't expect a connection here, did we now...";
$fh->close;
};
say "Got listening port $st_server_port for the stunnel server";
undef $dummy;
say 'Let us hope this was enough to get stunnel to listen there...';
}
my ($st_pid, $st_logfile);
{
my $st_config = $tempdir->child('stunnel.conf');
$st_logfile = $tempdir->child('stunnel.log');
my $st_pidfile = $tempdir->child('stunnel.pid');
$st_config->spew_utf8(<<"EOCONF") or die "Could not create the $st_config stunnel config file: $!\n";
pid = $st_pidfile
foreground = yes
output = $st_logfile
cert = $certfile
key = $keyfile
[test]
accept = $listen_address:$st_server_port
connect = $listen_address:$listen_clear_port
EOCONF
say "Created the stunnel config file $st_config:\n======\n".$st_config->slurp_utf8.'======';
$st_pid = fork;
if (!defined $st_pid) {
die "Could not fork for the stunnel server: $!\n";
} elsif ($st_pid == 0) {
my @cmd = ($stunnel, $st_config);
exec { $cmd[0] } @cmd;
die "Could not execute '@cmd': $!\n";
}
say "Started the stunnel server, pid $st_pid";
register_child $st_pid, "stunnel server ($listen_address:$st_server_port)";
}
{
for my $iter (1..10) {
say "Trying a connection through stunnel, iteration $iter";
my $st_conn_cv = AnyEvent->condvar;
my $st_conn;
{
my $st_conn_attempts = 10;
my $st_conn_timer;
$st_conn_timer = AnyEvent->timer(after => 0.1, interval => 1, cb => sub {
say "Trying to connect to the stunnel server at $listen_address:$st_server_port";
$st_conn = tcp_connect $listen_address, $st_server_port, sub {
my ($fh) = @_;
if (!defined $fh) {
# FIXME: Eh, well, reschedule, right?
say "Could not connect to $listen_address:$st_server_port: $!";
if ($children{$st_pid}{cv}->ready) {
say 'Err, the stunnel process seems to have terminated';
undef $st_conn_timer;
$st_conn_cv->send(undef);
return;
}
$st_conn_attempts--;
if ($st_conn_attempts == 0) {
say 'Time after time...';
undef $st_conn_timer;
$st_conn_cv->send(undef);
return;
}
say 'Will retry in a little while';
return;
}
say '...connected!';
$st_conn_timer = undef;
$st_conn_cv->send($fh);
};
});
}
my $st_conn_fh = $st_conn_cv->recv;
if (!defined $st_conn_fh) {
my $log_text = (-f $st_logfile)
? "$st_logfile contents:\n".$st_logfile->slurp_utf8
: "(no log information)";
$log_text .= "\n" unless $log_text =~ /\n\Z/ms;
die "Could not connect to the stunnel service:\n$log_text";
}
my $id = register_client_connection $st_conn_fh;
say "Registered a client connection as $id";
adopt_client_connection $id, { tls => 'connect', };
say 'Waiting for the cleartext listener to receive this connection';
my $stunnel_test_done = AnyEvent->condvar;
await_client_connection $lis_main, $stunnel_test_done, 1;
my $sid = $stunnel_test_done->recv;
if (!defined $sid) {
die "The listener did not acknowledge the connection\n";
} elsif ($sid eq $id) {
die "The listener reported the same connection ID '$id'?!\n";
}
say "The server reported a completed connection: $sid";
my $res = $conns{$id}{cv}->recv;
if (!defined $res) {
die "The connection to stunnel did not report a successful chat\n";
}
say "The stunnel connection seems to have gone through for iteration $iter";
}
}
{
say "Trying to stop stunnel at pid $st_pid";
kill 'TERM', $st_pid or
die "Could not send a terminate signal to the stunnel at pid $st_pid: $!\n";
my $status = wait_for_child $st_pid;
if ($status != 0) {
die "The stunnel process terminated with exit status $status\n";
} else {
say 'The stunnel process terminated successfully';
}
}
{
say 'Checking for leftover children';
if (%children) {
# Our 'die' handler will kill and reap them.
die "Child processes left over:\n".
dump_children;
} else {
say 'No child processes left over';
}
unregister_child_reaper;
};
{
say 'Making sure the AnyEvent loop is still sane';
if ($test_done->ready) {
die "The AnyEvent loop raised the flag prematurely\n";
}
$test_done->send(42);
my $res = $test_done->recv;
if ($res != 42) {
die "The AnyEvent loop does not seem to be quite alive and sane, got a result of '$res' instead of 42\n";
}
say 'Fine!';
};
}