view release on metacpan or  search on metacpan

t/fuguvm/autoinstall.t  view on Meta::CPAN

	open my $fh, '>', $file or die "Cannot write $file: $!";
	print $fh "System hostname = image\n";
	print $fh "HTTP proxy URL = \@PROXY_URL\@\n";
	close $fh;

	my $responder = App::FuguVM::Autoinstall->new(
		file      => $file,
		pidfile   => Fugu::Pidfile->new( path => "$dir/autoinstall.pid" ),
		store     => $store,
		proxy_url => 'http://10.0.2.2:8080',
		logfile   => "$dir/autoinstall.log",
	);

	my $port = $responder->start;
	skip 'no free port in the responder range', 16 if !defined $port;

	ok( $port >= 8181 && $port <= 8280, 'start returns a port of the range' );
	ok( $responder->is_running, 'the child is alive' );
	is( $responder->port, $port, 'port returns the recorded port' );
	is( $responder->start, $port,
		'a second start returns the port and starts nothing' );

	my $expected = "System hostname = image\n"
	    . "HTTP proxy URL = http://10.0.2.2:8080\n";

	my ( $head, $body ) = _request( $port, "GET /install.conf HTTP/1.1" );
	like( $head, qr{^HTTP/1\.1 200 }, 'GET /install.conf answers 200' );
	like( $head, qr{^Content-Type: text/plain\r?$}m,
		'with Content-Type: text/plain' );
	like( $head, qr{^Content-Length: @{[length $expected]}\r?$}m,
		'with the Content-Length of the rendered bytes' );
	is( $body, $expected, 'and the rendered bytes as the body' );

	( $head, $body ) = _request( $port, "HEAD /install.conf HTTP/1.1" );
	like( $head, qr{^HTTP/1\.1 200 }, 'HEAD answers 200' );
	is( $body, '', 'with the headers only' );

	($head) = _request( $port, "GET /elsewhere HTTP/1.1" );
	like( $head, qr{^HTTP/1\.1 404 }, 'another path answers 404' );

	($head) = _request( $port, "POST /install.conf HTTP/1.1" );
	like( $head, qr{^HTTP/1\.1 405 }, 'another method answers 405' );

	# The child binds the loopback address only, because the file
	# can hold a secret. The probe connects to the outbound address
	# of this host, and it skips when the host has none. Some
	# networks intercept and accept each connection. A refusal
	# cannot occur there, and the probe also skips.
	my $outbound = _outbound_address();
	if ( !defined $outbound || $outbound eq '127.0.0.1' ) {
		pass('no outbound address to probe, loopback bind unproven');
	}
	elsif ( _network_intercepts($outbound) ) {
		pass('the network accepts each connection, loopback bind unproven');
	}
	else {
		my $reached = IO::Socket::INET->new(
			PeerAddr => $outbound,
			PeerPort => $port,
			Proto    => 'tcp',
			Timeout  => 2,
		);
		is( $reached, undef,
			"a connection to $outbound:$port fails" );
	}

	ok( $responder->stop, 'stop returns 1' );
	ok( !$responder->is_running, 'the child is gone' );
	is( $responder->port, undef, 'port returns undef after stop' );
}

done_testing();

# _request($port, $line):
#	Send one request and return the head and the body.
sub _request ( $port, $line )
{
	my $sock = IO::Socket::INET->new(
		PeerAddr => '127.0.0.1',
		PeerPort => $port,
		Proto    => 'tcp',
		Timeout  => 5,
	) or die "Cannot connect to 127.0.0.1:$port: $!";

	print $sock "$line\r\nHost: 127.0.0.1\r\n\r\n";
	my $answer = do { local $/; <$sock> };
	close $sock;

	my ( $head, $body ) = split /\r\n\r\n/, $answer, 2;
	return ( $head, $body // '' );
}

# _outbound_address():
#	Return the local address of an outbound socket, or undef. The
#	datagram never leaves the host: connect on UDP only records
#	the route.
sub _outbound_address ()
{
	my $sock = IO::Socket::INET->new(
		PeerAddr => '203.0.113.1',
		PeerPort => 53,
		Proto    => 'udp',
	) or return;

	my $address = $sock->sockhost;
	close $sock;

	return $address;
}

# _network_intercepts($address):
#	Return 1 when a connection to a closed port on $address
#	succeeds. That network intercepts each connection, and a
#	bind probe proves nothing there.
sub _network_intercepts ($address)
{
	my $listener = IO::Socket::INET->new(
		LocalAddr => '127.0.0.1',
		LocalPort => 0,
		Proto     => 'tcp',
		Listen    => 1,
	) or return 0;

	my $closed = $listener->sockport;
	close $listener;

	my $sock = IO::Socket::INET->new(
		PeerAddr => $address,
		PeerPort => $closed,
		Proto    => 'tcp',
		Timeout  => 2,
	) or return 0;

	close $sock;

	return 1;
}