view release on metacpan or  search on metacpan

lib/App/FuguVM/Guest.pm  view on Meta::CPAN

# $self->_proxy:
#	Build the proxy supervisor over this VM's state.
sub _proxy ($self)
{
	my $state = $self->{state};

	return App::FuguVM::Proxy->new(
		cache   => App::FuguVM::Proxy::Cache->new( $self->_cache_dir ),
		pidfile => $state->proxy_pidfile,
		store   => $state->store,
		logfile => $state->vm_state_dir . '/proxy.log',
		log     => $self->{log},
	);
}

# $self->_force_stop:
#	Stop the QEMU process deterministically. Send SIGTERM first:
#	QEMU exits and flushes its disk caches. Escalate to SIGKILL if
#	the process stays. Unlike a QMP 'quit', this method cannot hang
#	on an unresponsive monitor socket. Thus it is a safe last
#	resort.
sub _force_stop ($self)
{
	my $pid = $self->{state}->get_vm_pid;
	return 1 if !defined $pid;
	return Fugu::Process->terminate( $pid, grace_period => 5 );
}

# QMP methods
sub _qmp_socket_path ($self)
{
	return $self->{state}{vm_state_dir} . '/qmp.sock';
}

sub _qmp_connect ($self)
{
	my $qmp = App::FuguVM::QMP->new( $self->_qmp_socket_path );
	return $qmp->open_connection ? $qmp : undef;
}

sub _qmp_powerdown ($self)
{
	my $qmp    = $self->_qmp_connect or return 0;
	my $result = $qmp->powerdown;
	$qmp->disconnect;
	return $result;
}

sub _qmp_quit ($self)
{
	my $qmp = $self->_qmp_connect or return 0;
	return $qmp->quit;
}

sub _is_running ($self)
{
	my $pid = $self->{state}->get_vm_pid;
	return 0 if !defined $pid;

	# A QEMU that became a zombie is not running. Fugu::Process
	# reaps it and says so; a bare kill(0) would call it alive.
	return Fugu::Process->is_alive($pid) ? 1 : 0;
}

# $self->_wait_exit($timeout):
#	Wait for the QEMU process to leave. The poll is sub-second, so
#	a VM that stops at once does not cost a whole second.
sub _wait_exit ( $self, $timeout )
{
	my $pid = $self->{state}->get_vm_pid;
	return 1 if !defined $pid;

	return Fugu::Process->wait_exit( $pid, $timeout );
}

# QEMU startup
sub _start_qemu ( $self, $boot_image = undef )
{
	my $config = $self->{config};
	my $state  = $self->{state};

	my @cmd = (QEMU_BINARY);

	# Set the machine type for arm64. Select the accelerator by the
	# host capability.
	push @cmd, '-M', 'virt,highmem=off';
	push @cmd, $self->_accel_args;

	# Memory and CPU
	push @cmd, '-m',   $config->{memory} // MEMORY_DEFAULT;
	push @cmd, '-smp', CPU_COUNT;

	# EFI firmware for arm64
	my $bios = $self->_find_efi_firmware;
	if ( defined $bios ) {
		push @cmd, '-bios', $bios;
	}

	# The main disk with the safe cache mode. The writethrough mode
	# syncs on each write.
	my $disk_path = $state->disk_path;
	push @cmd, '-drive',
	    "file=$disk_path,format=qcow2,if=virtio,cache=writethrough";

	# Boot image (CD-ROM) for installation
	if ( defined $boot_image ) {
		push @cmd, '-drive',
		    "file=$boot_image,format=raw,if=virtio,readonly=on";
	}

	# Network with port forwarding
	my $ssh_port = $config->{ssh_port};
	push @cmd, '-device', 'virtio-net-pci,netdev=net0';
	push @cmd, '-netdev', "user,id=net0,hostfwd=tcp::$ssh_port-:22";

	# Serial console on telnet
	my $console_port = $config->{console_port};
	push @cmd, '-serial', "tcp::$console_port,server,telnet,nowait";

	# QMP control socket
	my $qmp_path = $self->_qmp_socket_path;
	unlink $qmp_path if -S $qmp_path;
	push @cmd, '-qmp', "unix:$qmp_path,server,nowait";

	# PID file for reliable tracking
	push @cmd, '-pidfile', $state->vm_pidfile->path;

	# No graphics display (headless)
	push @cmd, '-display', 'none';

	# Use Fugu::Process to spawn QEMU
	my $log_file = $state->vm_state_dir . '/qemu.log';
	my $result   = Fugu::Process->spawn_command(
		cmd       => \@cmd,
		daemonize => 1,
		stdout    => $log_file,
		stderr    => $log_file,
	);

	return unless $result->{success};

	# Wait until QEMU writes the PID file
	my $pid = Fugu::Timeout::wait_until(
		5, 0.1,
		sub {
			my $qemu_pid = $state->get_vm_pid;
			return $qemu_pid
			    if defined $qemu_pid
			    && Fugu::Process->is_alive($qemu_pid);
			return;
		} );

	unless ( defined $pid ) {
		$self->_dump_qemu_log($log_file);
		return;
	}

	# Arm the crash detection: was_unclean_shutdown reports true
	# when the state says running and the process is gone.
	$state->mark_running;

	# Make sure that QEMU accepts console connections before the
	# installer tries to attach. A QEMU that exited at startup, for
	# example with a bad accelerator or missing firmware, leaves the
	# port closed. This check fails fast with the QEMU log, not with
	# a long telnet timeout later.
	if ( defined $boot_image
		&& !$self->_wait_console_ready( $config->{console_port}, 30 ) )
	{
		$self->{log}
		    ->error( 'QEMU console port %d not listening after start',
			$config->{console_port} );
		$self->_dump_qemu_log($log_file);
		return;
	}

	return $pid;
}

# $self->_wait_console_ready($port, $timeout):
#	Poll the console TCP port until it accepts a connection. Thus
#	the telnet of the installer attaches to a live console. QEMU
#	binds the port at startup, before the guest boots. Thus the
#	poll is quick when QEMU is healthy, and bounded when it is not.
sub _wait_console_ready ( $self, $port, $timeout )
{
	require IO::Socket::INET;

	my $ready = Fugu::Timeout::wait_until(
		$timeout, 0.2,
		sub {
			my $sock = IO::Socket::INET->new(
				PeerAddr => '127.0.0.1',
				PeerPort => $port,
				Proto    => 'tcp',
				Timeout  => 2,
			);
			if ( defined $sock ) {
				$sock->close;
				return 'ready';
			}

			# Stop the wait early if QEMU already exited
			my $qemu_pid = $self->{state}->get_vm_pid;
			return 'gone'
			    if defined $qemu_pid
			    && !Fugu::Process->is_alive($qemu_pid);

			return;
		} );

	return defined $ready && $ready eq 'ready' ? 1 : 0;
}

# $self->_dump_qemu_log($log_file):
#	Show the tail of the QEMU log. Thus a startup failure is
#	visible in the CI output, and shell access to the runner is not
#	necessary.
sub _dump_qemu_log ( $self, $log_file )
{
	open my $fh, '<', $log_file or return;
	my @lines = <$fh>;
	close $fh;

	@lines = splice( @lines, -40 ) if @lines > 40;
	$self->{log}->error('QEMU log tail:');
	$self->{log}->error( '  %s', $_ ) for map { chomp; $_ } @lines;

	return;
}

# $self->_accel_args():
#	Pick the QEMU accelerator for the host. Use HVF on macOS. Use
#	KVM on aarch64 Linux hosts with /dev/kvm. Use TCG software
#	emulation in the other cases, or when --emulate was given. Host
#	CPU passthrough is only valid with hardware acceleration. TCG
#	needs a named model.
sub _accel_args ($self)
{
	my $accel;
	if ( $self->{emulate} ) {
		$accel = 'tcg';
	}
	elsif ( $^O eq 'darwin' ) {
		$accel = 'hvf';
	}
	elsif ( $^O eq 'linux' && -w '/dev/kvm' && _host_arch() eq 'aarch64' ) {
		$accel = 'kvm';
	}
	else {
		$accel = 'tcg';
	}

	$self->{log}->debug("Using QEMU accelerator: $accel")
	    if $self->{log};

	return ( '-accel', $accel, '-cpu', $accel eq 'tcg' ? TCG_CPU : 'host' );
}

# _host_arch():
#	Return the host machine architecture from uname.
sub _host_arch ()
{
	require POSIX;
	my @uname = POSIX::uname();
	return $uname[4] // '';
}