view release on metacpan or  search on metacpan

lib/App/OpenHAP/Test/Integration.pm  view on Meta::CPAN

	open my $fh, '<', PAIRINGS_FILE or return 0;
	while (<$fh>) {
		next if /^#/ || /^\s*$/;
		close $fh;
		return 1;
	}
	close $fh;

	return 0;
}

# $self->_verify_unpaired():
#	Probe the pairing state with POST /identify. The daemon
#	returns 204 only when unpaired. It returns 400 with
#	{"status":-70401} when still paired (HAP-HTTP.md §3). This
#	sub fails loudly on the paired answer. It closes the probe
#	socket immediately. The socket does not stay registered with
#	the daemon until teardown.
sub _verify_unpaired ($self)
{
	my $before   = scalar @{ $self->{sockets} };
	my $response = $self->http_request( 'POST', '/identify' );
	for my $socket ( splice @{ $self->{sockets} }, $before ) {
		$socket->close if defined $socket;
	}

	unless ( defined $response ) {
		warn "No response to identify probe\n";
		return;
	}

	my ($status) = parse_http_response($response);
	return 1 if defined $status && $status == 204;

	warn sprintf "Daemon not unpaired: identify returned %s\n",
	    $status // 'no status';

	return;
}

# $self->close_sockets():
#	Close and forget every raw socket that http_request opened.
#	Then a probe connection does not stay registered with the
#	daemon until teardown.
sub close_sockets ($self)
{
	for my $socket ( @{ $self->{sockets} } ) {
		$socket->close if defined $socket;
	}
	$self->{sockets} = [];

	return 1;
}

sub http_request ( $self, $method, $path, $body = undef, $headers = {} )
{
	my $socket = IO::Socket::INET->new(
		PeerAddr => '127.0.0.1',
		PeerPort => $self->{hap_port},
		Proto    => 'tcp',
		Timeout  => 2,
	);
	return unless defined $socket;

	push @{ $self->{sockets} }, $socket;

	print {$socket} Protocol::HAP::HTTP::build_request(
		method  => $method,
		path    => $path,
		body    => $body,
		headers => { Host => "127.0.0.1:$self->{hap_port}", %$headers },
	);
	$socket->flush;

	# Read until the buffer holds one whole message. A stream
	# socket gives whatever arrived, which is not a message.
	my $response = '';
	while (1) {
		last
		    if Protocol::HAP::HTTP::message_complete( $response,
			max_size => MAX_RESPONSE );

		my $bytes = $socket->sysread( my $chunk, 65536 );
		last unless $bytes;
		$response .= $chunk;
	}

	return $response;
}

sub parse_http_response ($response)
{
	return unless defined $response;

	my $parsed = Protocol::HAP::HTTP::parse_response($response) or return;

	return ( $parsed->{status}, $parsed->{headers}, $parsed->{body} );
}

# status($response):
#	Return the status code of an HTTP response, for the tests
#	that need nothing else from it.
sub status ($response)
{
	my ($status) = parse_http_response($response);

	return $status;
}

# $self->find_char($database, $type, %opt):
#	Find a characteristic by its short type string in a decoded
#	/accessories structure. The walk skips the bridge (aid 1).
#	The option name limits the walk to the accessory whose Name
#	characteristic holds that value. The option ev demands the ev
#	permission. Return (aid, iid, characteristic) on a match.
#	Return the empty list when there is no match.
sub find_char ( $self, $database, $type, %opt )
{
	for my $accessory ( @{ $database->{accessories} // [] } ) {
		next if $accessory->{aid} == 1;
		next

lib/App/OpenHAP/Test/Integration.pm  view on Meta::CPAN

		}
		elsif ( defined $value && "$value" eq "$want" ) {
			return 1;
		}
		return if time >= $deadline;
		sleep 0.25;
	}
}

sub get_config_value ( $self, $key )
{
	return $self->{config}{$key};
}

# $self->get_device_topics():
#	Return the MQTT topic of each configured device that has one.
sub get_device_topics ($self)
{
	return
	    map { $_->{topic} } grep { defined $_->{topic} } $self->get_devices;
}

# $self->get_devices():
#	Return the configured device records as a list of hashes with
#	type, subtype, id, name, and topic.
sub get_devices ($self)
{
	return @{ $self->{devices} // [] };
}

sub ensure_daemon_running ($self)
{
	if ( !_rcctl( 'check', 'openhapd' ) ) {
		_rcctl( 'start', 'openhapd' );
		sleep 1;
		return if !_rcctl( 'check', 'openhapd' );
	}

	# A daemon that runs per rcctl does not serve yet. At
	# startup, the daemon publishes the mDNS advertisement and
	# waits for the mdnsd replies. The HAP listener opens after
	# that. Thus wait for the port, not for a fixed sleep.
	return $self->wait_for_hap_port;
}

# $self->wait_for_hap_port($timeout):
#	Wait until the HAP port accepts connections. Poll every
#	quarter second, up to $timeout seconds. The default is 30
#	seconds, which is generous for TCG emulation. Return 1 when
#	the daemon serves. Return undef on the deadline.
sub wait_for_hap_port ( $self, $timeout = 30 )
{
	my $port     = $self->get_config_value('hap_port') // DEFAULT_HAP_PORT;
	my $deadline = time + $timeout;

	while ( time < $deadline ) {
		my $socket = IO::Socket::INET->new(
			PeerAddr => '127.0.0.1',
			PeerPort => $port,
			Proto    => 'tcp',
			Timeout  => 2,
		);
		if ( defined $socket ) {
			$socket->close;
			return 1;
		}
		sleep 0.25;
	}

	return;
}

sub ensure_daemon_stopped ($self)
{
	return 1 if !_rcctl( 'check', 'openhapd' );

	_rcctl( 'stop', 'openhapd' );
	sleep 1;

	return !_rcctl( 'check', 'openhapd' );
}

# $self->restart_daemon():
#	Restart openhapd through rcctl. Then wait until the HAP port
#	serves again. Return 1 when the daemon serves. Return undef
#	on failure.
sub restart_daemon ($self)
{
	_rcctl( 'restart', 'openhapd' );
	$self->wait_for_hap_port or return;

	return 1;
}

# $self->ensure_mdnsd_running():
#	Make sure that mdnsd runs and continues to run. Start it if
#	necessary. Then check again across a settle window. A
#	point-in-time probe races green when mdnsd starts and then
#	exits shortly after. On failure, emit the captured
#	diagnostics. Then a dead mdnsd is diagnosable from the test
#	output, and the sub does not fail bare.
sub ensure_mdnsd_running ($self)
{
	my $check = sub { _rcctl( 'check', 'mdnsd' ) };

	unless ( $check->() ) {
		_rcctl( 'enable', 'mdnsd' );
		_rcctl( 'start',  'mdnsd' );
	}

	for my $probe ( 1 .. 3 ) {
		sleep 1;
		next if $check->();
		$self->_warn_mdnsd_diagnostics(
			"mdnsd not running at settle probe $probe/3");
		return;
	}

	return 1;
}