#!/usr/bin/perl -Tw

# adapted from perlipc(1)

use strict;
use POSIX 'strftime';
use Socket;
use Carp;

sub spawn;  # forward declaration
sub logmsg { print strftime("%F %T", localtime), " $0 $$: @_\n" }

my $port = shift || 2345;
my $proto = getprotobyname('tcp');

($port) = $port =~ /^(\d+)$/                        or die "invalid port";

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
			       pack("l", 1))   || die "setsockopt: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

logmsg "server started on port $port";

my $waitedpid = 0;
my $paddr;

use POSIX ":sys_wait_h";
use Errno;

sub REAPER {
	local $!;   # don't let waitpid() overwrite current error
	while ((my $pid = waitpid(-1,WNOHANG)) > 0 && WIFEXITED($?)) {
		logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
	}
	$SIG{CHLD} = \&REAPER;  # loathe sysV
}

$SIG{CHLD} = \&REAPER;

my $seq_nr;
while(1) {
	$paddr = accept(Client, Server) || do {
		# try again if accept() returned because a signal was received
		next if $!{EINTR};
		die "accept: $!";
	};
	my ($port, $iaddr) = sockaddr_in($paddr);
	my $name = gethostbyaddr($iaddr, AF_INET);

	logmsg "connection from $name [", inet_ntoa($iaddr), "] at port $port";

	spawn \&pong_ping_with_guard_bytes;
	close Client;
}

sub spawn {
	my $coderef = shift;

	unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
		confess "usage: spawn CODEREF";
	}

	my $pid;
	if (! defined($pid = fork)) {
		logmsg "cannot fork: $!";
		return;
	}
	elsif ($pid) {
		logmsg "begat $pid";
		return; # I'm the parent
	}
	# else I'm the child -- go spawn

	$seq_nr = 0;

	open(STDIN,  "<&Client")   || die "can't dup client to stdin";
	open(STDOUT, ">&Client")   || die "can't dup client to stdout";
	## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
	exit &$coderef();
}

sub random_packet()
{
	# TODO: add checksum
	my $p_len = int(rand(33000));
	pack("Nnn", 0xb1b2b3b4, 0x3333, $p_len + 4) .
	("\x55" x $p_len) . pack("N", 0xe4e3e2e1);
}

sub receive_and_validate_packet {
	my ($hdr, $payload, $magic, $cmd, $len);
	$hdr = "\xbb\xaa\x99\x88" x 1024; # stupid; just to see where the corruption is from.
	if (!defined(recv STDIN, $hdr, 8, MSG_WAITALL)) {
		logmsg "recv hdr error [$seq_nr]: $!";
		return 1;
	}
	if (length($hdr) != 8) {
		logmsg "recv hdr [$seq_nr]: too short: ",
			join " ", map { sprintf "%02x", $_ } unpack "C*", $hdr;
		return 1;
	}
	($magic, $cmd, $len) = unpack "Nnn", $hdr;
	if ($magic != 0xb1b2b3b4) {
		logmsg "recv hdr [$seq_nr]: invalid magic: ",
			join " ", map { sprintf "%02x", $_ } unpack "C*", $hdr;
		return 1;
	}
	if (!defined(recv STDIN, $payload, $len, MSG_WAITALL)) {
		logmsg "recv payload error [$seq_nr]: $!";
		return 1;
	}
	my $plen = length($payload);
	my $p_last_4 = substr($payload, -4, 4);
	my $p_trail_magic = unpack "N", $p_last_4;
	if ($plen != $len) {
		logmsg "recv payload [$seq_nr]: expected $len, but received $plen byte; last bytes received: ",
			join " ", map { sprintf "%02x", $_ } unpack "C*", $p_last_4;
		return 1;
	}
	if ($p_trail_magic != 0xe4e3e2e1) {
		logmsg "recv payload [$seq_nr]: invalid trailing magic; last bytes received: ",
			join " ", map { sprintf "%02x", $_ } unpack "C*", $p_last_4;
		return 1;
	}
	++$seq_nr;
	return 0;
}

sub send_random_packet() {
	my $p = random_packet();
	my $p_len = length($p);
	# this is supposedly a blocking send,
	# so it should send the whole packet!
	my $s_len = send STDOUT, $p, 0;
	if (!defined($s_len)) {
		logmsg "send error: $!";
		return 1;
	}
	if ($s_len != $p_len) {
		logmsg "send error: wanted to send $p_len, but could only send $s_len bytes";
		return 1;
	}
}

sub pong_ping_with_guard_bytes {
	my $ret;
	while (1) {
		$ret = receive_and_validate_packet();
		return $ret if $ret;
		$ret = send_random_packet();
		return $ret if $ret;
	}
	logmsg "received $seq_nr packets\n";
	return 0;
}
