648 lines
16 KiB
Perl
Executable File
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!';
|
|
};
|
|
}
|