# test INTERcal NETworking -- theft server

# Copyright (c) 2023 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

# PERVERSION: CLC-INTERCAL/INET t/05theft-server.t 1.-94.-2.4

use strict;
use warnings;

use Language::INTERCAL::Time '1.-94.-2.3', qw(current_time);
my ($started, $timeout);
BEGIN { $started = current_time; }

use POSIX qw(WNOHANG);
use FindBin '$Bin';
use File::Spec::Functions;
use Language::INTERCAL::Server::IPv6 '1.-94.-2.4', qw(has_ipv6);
use Language::INTERCAL::Server::Test '1.-94.-2.4';
use Language::INTERCAL::Theft '1.-94.-2.4';

my $toplevel = @ARGV && $ARGV[0] eq 'toplevel';
my $ipv6 = has_ipv6();
if ($ipv6) {
    require Socket;
    import Socket qw(inet_pton AF_INET6);
}

my $test = Language::INTERCAL::Server::Test->new;
my $interfaces = $test->interfaces;

# find interfaces for IPv4 broadcast and IPv6 multicast
my ($if4) = $interfaces->broadcasts;
defined $if4 or die "if4 undef?\n";
my $if6;
if (has_ipv6()) {
    ($if6) = $interfaces->interfaces6;
    $if6 and $if6 = $interfaces->interface_index($if6);
}
my ($lo4) = $interfaces->localhost_addresses(4);
my ($lo6) = $interfaces->localhost_addresses(6);

use constant ALWAYS            =>  0;
use constant HAS_THEFT_PID     =>  1;
use constant HAS_THEFT_PORT    =>  2;
use constant HAS_THEFT_SOCKET  =>  4;
use constant HAS_VICTIM_PID    =>  8;
use constant HAS_VICTIM_PORT   => 16;
use constant HAS_VICTIM_SOCKET => 32;
use constant HAS_CONTROL_PID   => 64;

# We use 32 bits of randomness in the group so different "make test"
# on the same host have less chance to interfere with each other
# this is no longer really necessary as we do not use a real network
# for this test but we'll keep the randomness in.
use constant MULTICAST_GROUP   =>
    sprintf 'ff11::%x:%x', 1 + int(rand(65535)), 1 + int(rand(65535));
use constant MESSAGE           => 'The Magic Words are Squeamish Ossifrage';

my ($theft_port, $theft_pid, $victim_pid, $victim_port, $victim_conn, $control_pid, $control_conn);

my @tests = (
    # start a theft-server
    [ALWAYS,            'START THEFT',   \&start_theft],
    # test the theft-server itself
    [HAS_THEFT_PID,     'START CONTROL', \&start, \$control_pid, undef, 'control', \&control],
    [HAS_CONTROL_PID,   'CONNECT',       \&connect, \$control_pid, \$control_conn],
    [HAS_THEFT_SOCKET,  'VICTIM',        \&introduce, \$control_pid],
    [HAS_THEFT_SOCKET,  'CASE PID',      \&case_pid, \$control_pid, 1],
    [HAS_THEFT_SOCKET,  'CASE PORT',     \&case_port, \$control_pid, 1],
    [HAS_THEFT_SOCKET,  'DISCONNECT',    \&disconnect, \$control_pid, \$control_conn],
    [HAS_CONTROL_PID,   'STOP CONTROL',  \&stop, 'control', \$control_pid],
    # now test queries, STEAL and SMUGGLE
    [HAS_THEFT_PORT,    'RUN',           \&start, \$victim_pid, \$victim_port, 'victim', \&victim],
    [HAS_VICTIM_PORT,   'CONNECT',       \&connect, \$victim_pid, \$victim_conn],
    [HAS_VICTIM_SOCKET, 'CASE PID',      \&case_pid, \$victim_pid, \$victim_port],
    [HAS_VICTIM_SOCKET, 'CASE PORT',     \&case_port, \$victim_pid, \$victim_port],
    [HAS_VICTIM_SOCKET, 'DISCONNECT',    \&disconnect, \$victim_pid, \$victim_conn],
    [HAS_VICTIM_PORT,   'STEAL V4',      \&steal_smuggle, 'STEAL', $lo4],
    [HAS_VICTIM_PORT,   'SMUGGLE V4',    \&steal_smuggle, 'SMUGGLE', $lo4],
(defined $if4 ? (
    # test broadcasts
    [HAS_VICTIM_PORT,   'BROADCAST',     \&theft_broadcast, 0],
    [HAS_VICTIM_PORT,   'BROADCAST PID', \&theft_broadcast, 1],
) : ()),
(defined $if6 ? (
    # test multicasts
    [HAS_VICTIM_PORT,   'MULTICAST',     \&theft_multicast, 0],
    [HAS_VICTIM_PORT,   'MULTICAST PID', \&theft_multicast, 1],
) : ()),
($ipv6 ? (
    [HAS_VICTIM_PORT,   'STEAL V6',      \&steal_smuggle, 'STEAL', $lo6],
    [HAS_VICTIM_PORT,   'SMUGGLE V6',    \&steal_smuggle, 'SMUGGLE', $lo6],
) : ()),
    [HAS_VICTIM_PID,    'FINISH',        \&stop, 'victim', \$victim_pid, \$victim_port],
    # stop the theft-server
    [HAS_THEFT_PID,     'STOP THEFT',    \&stop, 'theft-server', \$theft_pid, \$theft_port],
);

print "1..", scalar(@tests), "\n";
my $num = 0;
for my $test (@tests) {
    my ($started, $name, $code, @args) = @$test;
    $num++;
    if (($started & HAS_THEFT_PORT) && ! defined $theft_port) {
	print "not ok $num Cannot run test $name without a theft-server port\n";
	$toplevel or print STDERR "Cannot run test $name without a theft-server port\n";
    } elsif (($started & HAS_THEFT_PID) && ! defined $theft_pid) {
	print "not ok $num Cannot run test $name without a theft-server PID\n";
	$toplevel or print STDERR "Cannot run test $name without a theft-server PID\n";
    } elsif (($started & HAS_THEFT_SOCKET) && ! defined $control_conn) {
	print "not ok $num Cannot run test $name without a theft-server connection\n";
	$toplevel or print STDERR "Cannot run test $name without a theft-server connection\n";
    } elsif (($started & HAS_VICTIM_PID) && ! defined $victim_pid) {
	print "not ok $num Cannot run test $name without a victim PID\n";
	$toplevel or print STDERR "Cannot run test $name without a victim PID\n";
    } elsif (($started & HAS_VICTIM_PORT) && ! defined $victim_port) {
	print "not ok $num Cannot run test $name without a victim PORT\n";
	$toplevel or print STDERR "Cannot run test $name without a victim PORT\n";
    } elsif (($started & HAS_VICTIM_SOCKET) && ! defined $victim_conn) {
	print "not ok $num Cannot run test $name without a victim connection\n";
	$toplevel or print STDERR "Cannot run test $name without a victim connection\n";
    } elsif (($started & HAS_CONTROL_PID) && ! defined $control_pid) {
	print "not ok $num Cannot run test $name without a control PID\n";
	$toplevel or print STDERR "Cannot run test $name without a control PID\n";
    } else {
	eval { $code->(@args); };
	if ($@) {
	    print "not ok $num $name: $@";
	    $toplevel or print STDERR "$name: $@";
	} else {
	    print "ok $num $name\n";
	}
    }
}

exit 0;

sub start_theft {
    # server is in blib/script and we don't want to search for it or we may
    # get the wrong one
    my @theft = (
	$^X,
	(map { ('-I', $_) } @INC),
	catfile($Bin, updir(), qw(blib script theft-server)),
	qw(--port 0 --show-port --show-pid --linger 15 --testing),
	$ipv6 ? ('--group', MULTICAST_GROUP) : (),
	#'--debug',
    );
    my $tp = $test->create(@theft) or die "theft-server: $!\n";
    if (! defined $timeout) {
	my $now = current_time;
	$now -= $started;
	$timeout = int(($now->numify + 31000) / 32000);
    }
    local $SIG{ALRM} = sub { die "Timed out\n"; };
    alarm $timeout;
    while (defined (my $line = $test->get_info($tp, 1))) {
	$line =~ /^PID:\s*(\d+)\b/ and $theft_pid = $1;
	$line =~ /^PORT:\s*(\d+)\b/ and $theft_port = $1;
	$line =~ /__END__/ and last;
	alarm $timeout;
    }
    alarm 0;
    defined $theft_port or die "theft-server did not indicate listening port\n";
    defined $theft_pid or die "theft-server did not indicate its PID\n";
    $theft_pid == $tp or die "theft-server supposed to be PID $tp but indicate $theft_pid?\n";
}

sub _request {
    my ($pid, @req) = @_;
    if (! defined $timeout) {
	my $now = current_time;
	$now -= $started;
	$timeout = int(($now->numify + 31000) / 32000);
    }
    local $SIG{ALRM} = sub { die "Timed out\n"; };
    alarm $timeout;
    my $reply = $test->send_request($pid, join(' ', @req));
    alarm 0;
    $reply =~ /^ERR/ and die "$reply\n";
    $reply;
}

sub _list {
    my ($pid, @req) = @_;
    _request($pid, @req) or die "Error talking to process\n";
    my @reply = ();
    local $SIG{ALRM} = sub { die "Timed out\n"; };
    alarm $timeout;
    while (defined (my $line = $test->get_info($pid))) {
	$line eq '.' and last;
	push @reply, $line;
    }
    alarm 0;
    @reply;
}

sub start {
    my ($pid, $store, $name, $code, @args) = @_;
    my $cp = $test->create($code, @args) or die "$name: $!\n";
    my $v = _request($cp, 'Q') or die "$name did not start properly\n";
    $$pid = $cp;
    $store and $$store = $v;
}

sub control {
    my ($server) = @_;
    my ($theft_id);
    while (defined (my $line = $server->write_in('', 1))) {
	eval {
	    my $ok = 1;
	    if ($line =~ /^Q/) {
	    } elsif ($line =~ /^C/) {
		my $id = $server->tcp_socket($lo4, $theft_port);
		get_reply($server, $id);
		$theft_id = $id;
	    } elsif ($line =~ /^V/) {
		command($server, $theft_id, "VICTIM $$ ON PORT 1");
	    } elsif ($line =~ /^P/) {
		command($server, $theft_id, "CASE PID");
		my @pids = get_list($server, $theft_id);
		$server->info('', @pids, '.');
	    } elsif ($line =~ /^p/) {
		my $r = command($server, $theft_id, "CASE PORT $$");
		$server->read_out('', $r);
		$ok = 0;
	    } elsif ($line =~ /^D/) {
		command($server, $theft_id, 'THANKS');
		$server->tcp_socket_close($theft_id);
		$theft_id = undef;
	    } else {
		$server->read_out('', "ERR: Unknown message <$line>");
		$ok = 0;
	    }
	    $ok and $server->read_out('', $ok);
	};
	if ($@) {
	    print STDERR $@;
	    (my $msg = $@) =~ s/\s+/ /g;
	    $server->read_out('', "ERR: $msg");
	}
    }
}

sub _stop {
    my ($pid, $name) = @_;
    my $retry = 0;
    while (kill 0, $pid) {
	waitpid $pid, WNOHANG;
	$retry > 30 and die "Don't seem to be able to stop $name\n";
	kill $retry < 5 ? 'TERM' : 'KILL', $pid;
	select undef, undef, undef, 0.1;
    }
}

sub stop {
    my ($name, $pid, $port) = @_;
    _stop($$pid, $name);
    undef $$pid;
    $port and undef $$port;
}

sub connect {
    my ($pid, $conn) = @_;
    _request($$pid, 'C') or die "Error talking to process\n";
    $$conn = 1;
}

sub introduce {
    my ($pid) = @_;
    _request($$pid, 'V') or die "Error talking to process\n";
}

sub case_pid {
    my ($pid, $port) = @_;
    my @pids = _list($$pid, 'P');
    ref $port and $port = $$port;
    @pids == 1 && $pids[0] eq "$$pid ON PORT $port"
	or die "theft-server reported invalid PIDs (@pids), expected $$pid ON PORT $port\n";
}

sub case_port {
    my ($pid, $port) = @_;
    my $line = _request($$pid, 'p') or die "Error talking to process\n";
    ref $port and $port = $$port;
    $line =~ /^\d+\s+(\d+)\b/ && $1 == $port or die "theft-server reported invalid port: $line\n";
}

sub disconnect {
    my ($pid, $conn) = @_;
    _request($$pid, 'D') or die "Error talking to process\n";
    $$conn = undef;
}

sub get_reply {
    my ($server, $id) = @_;
    my $line = $server->write_in($id, 1);
    defined $line or die "No reply from theft-server\n";
    $line =~ /^2/ or die "Error from theft-server: $line\n";
    $line;
}

sub command {
    my ($server, $id, @data) = @_;
    $server->read_out($id, join(' ', @data));
    get_reply($server, $id);
}

sub get_list {
    my ($server, $id) = @_;
    my @list;
    while (1) {
	my $line = $server->write_in($id, 1);
	defined $line or die "Missing list in reply from theft-server\n";
	$line eq '.' and last;
	$line =~ s/^\.//;
	push @list, $line;
    }
    @list;
}

sub victim_request {
    _request($victim_pid, @_) or die "Error talking to process\n";
}

sub victim {
    my ($server) = @_;
    my $theft = Language::INTERCAL::Theft->_new(
	$server,
	$theft_port,
	$ipv6 ? [ [inet_pton(&AF_INET6, MULTICAST_GROUP), 0] ] : [],
	[(0) x 16],
	sub {
	    # steal/smuggle callback
	    my ($op, $reg, $id) = @_;
	    return "200 $op $reg";
	},
	undef,
    );
    my $myport = $theft->victim_port;
    my ($theft_id);
    while (defined (my $line = $server->write_in('', 1))) {
	eval {
	    my $ok = 1;
	    if ($line =~ /^Q/) {
		$ok = $myport;
	    } elsif ($line =~ /^C/) {
		my $id = $server->tcp_socket($lo4, $theft_port);
		get_reply($server, $id);
		$theft_id = $id;
	    } elsif ($line =~ /^V/) {
		command($server, $theft_id, "VICTIM $$ ON PORT 1");
	    } elsif ($line =~ /^D/) {
		command($server, $theft_id, 'THANKS');
		$server->tcp_socket_close($theft_id);
		$theft_id = undef;
	    } elsif ($line =~ /^P/) {
		command($server, $theft_id, "CASE PID");
		my @pids = get_list($server, $theft_id);
		$server->info('', @pids, '.');
	    } elsif ($line =~ /^p/) {
		my $r = command($server, $theft_id, "CASE PORT $$");
		$server->read_out('', $r);
		$ok = 0;
	    } elsif ($line =~ /^(STEAL|SMUGGLE)\s+(\S+)\s*$/) {
		my ($op, $addr) = ($1, $2);
		if (! defined $timeout) {
		    my $now = current_time;
		    $now -= $started;
		    $timeout = int(($now->numify + 31000) / 32000);
		}
		local $SIG{ALRM} = sub { die "Timeout talking to $addr\n"; };
		alarm $timeout;
		my $id = $server->tcp_socket($addr, $myport);
		get_reply($server, $id);
		my $line = command($server, $id, $op, ':1');
		$line =~ /^\d+\s+(\S+)\s+:1\b/ && $1 eq $op
		    or die "Invalid reply when ${op}ing :1: $line\n";
		command($server, $id, 'THANKS');
		$server->tcp_socket_close($id);
		alarm 0;
	    } elsif ($line =~ /^([MB])\s*(\d+)\b/) {
		my ($mc, $pid) = ($1, $2);
		my @res = $theft->find_theft_servers($mc ? undef : $if4, $pid);
	    } else {
		$server->read_out('', "ERR: Unknown message <$line>");
		$ok = 0;
	    }
	    $ok and $server->read_out('', $ok);
	};
	if ($@) {
	    print STDERR $@;
	    (my $msg = $@) =~ s/\s+/ /g;
	    $server->read_out('', "ERR: $msg");
	}
    }
}

sub steal_smuggle {
    my ($op, $addr) = @_;
    _request($victim_pid, "$op $addr") or die "Error talking to process\n";
}

sub theft_broadcast {
    my ($pid) = @_;
    _request($victim_pid, "B$pid") or die "Error talking to process\n";
}

sub theft_multicast {
    my ($pid) = @_;
    _request($victim_pid, "M$pid") or die "Error talking to process\n";
}

