#!/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!';
	};
}