view release on metacpan or  search on metacpan

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

# ex:ts=8 sw=4:
# $OpenBSD$
#
# Copyright (c) 2024 Dick Olsson <hi@senzilla.io>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

use v5.36;

# App::FuguVM::Guest - the lifecycle of one OpenBSD guest.
#
# The module creates, starts, waits for, stops, and destroys one
# guest. It drives QEMU over QMP, so the lifecycle verbs report what
# the hypervisor says and not what a sleep guessed.

package App::FuguVM::Guest;
our $VERSION = '0.1.1';

use App::FuguVM::Miniroot;
use App::FuguVM::DiskCache;
use App::FuguVM::Disk;
use App::FuguVM::Console;
use App::FuguVM::Proxy;
use App::FuguVM::QMP;

use Fugu::Random;
use Fugu::Process;
use Fugu::SSH;
use Fugu::Timeout;

use constant {
	EXIT_SUCCESS    => 0,
	EXIT_ERROR      => 1,
	EXIT_VM_RUNNING => 5,
	EXIT_TIMEOUT    => 7,

	# Fixed configuration for OpenBSD arm64 guests
	QEMU_BINARY    => 'qemu-system-aarch64',
	MEMORY_DEFAULT => '1G',
	CPU_COUNT      => 2,

	# The guest CPU model under TCG emulation. TCG does not use host
	# passthrough.
	TCG_CPU => 'cortex-a57',
};

sub new ( $class, %args )
{
	my $self = bless {
		config   => $args{config},
		state    => $args{state},
		log      => $args{log},
		emulate  => $args{emulate}  // 0,
		no_cache => $args{no_cache} // 0,
	}, $class;

	return $self;
}

# The operation is idempotent. It makes sure that the VM runs.
sub up ($self)
{
	my $config = $self->{config};
	my $state  = $self->{state};
	my $log    = $self->{log};

	# Check if the VM already runs
	if ( $self->_is_running ) {

		# The VM runs, but the SSH key is not installed or is not
		# current. This occurs when the first boot failed, or when
		# the key changed in the configuration.
		if ( $state->is_installed && $self->_needs_ssh_key_update ) {
			return $self->_complete_ssh_setup;