App-FuguVM
view release on metacpan or search on metacpan
lib/App/FuguVM/Autoinstall.pm view on Meta::CPAN
# QEMU gateway. Fugu::Proxy stays a proxy, and it gains no
# origin-server mode here.
package App::FuguVM::Autoinstall;
our $VERSION = '0.3.0';
use IO::Socket::INET;
use Fugu::File;
use Fugu::Log;
use Fugu::Process;
use Fugu::Timeout;
use App::FuguVM::Proxy;
use constant {
RESPONSE_PATH => '/install.conf',
# One range above the proxy range, so the two children cannot
# contend for one port.
PORTS => [ 8181, 8280 ],
BIND_ADDRESS => '127.0.0.1',
lib/App/FuguVM/Autoinstall.pm view on Meta::CPAN
return;
}
# $self->_wait_ready:
# Wait until the responder takes a connection.
sub _wait_ready ($self)
{
my $port = $self->port;
return 0 if !defined $port;
my $ready = Fugu::Timeout::wait_until(
READY_TIMEOUT,
0.2,
sub {
my $sock = IO::Socket::INET->new(
PeerAddr => BIND_ADDRESS,
PeerPort => $port,
Proto => 'tcp',
Timeout => 1,
) or return 0;
close $sock;
return 1;
} );
return $ready ? 1 : 0;
}
1;
lib/App/FuguVM/CLI.pm view on Meta::CPAN
$self->{log}->error("Invalid timeout value: $timeout");
return EXIT_INVALID_ARGS;
}
my $vm = $self->_load_vm or return $self->{load_exit};
my $port = $self->_require_port( $vm, 'ssh_port' );
return EXIT_ERROR if !defined $port;
if ( !$vm->wait_ssh($timeout) ) {
$self->{log}->error("Timeout waiting for SSH");
return EXIT_TIMEOUT;
}
$self->{log}->info("VM ready");
return EXIT_SUCCESS;
}
# Installed-image cache management
sub cmd_cache ( $self, $cli, @args )
{
lib/App/FuguVM/DiskCache.pm view on Meta::CPAN
package App::FuguVM::DiskCache;
our $VERSION = '0.3.0';
use Digest::SHA ();
use Fcntl qw(:flock);
use File::Path qw(remove_tree);
use Fugu::File;
use Fugu::Log;
use Fugu::Proxy;
use Fugu::Timeout;
use App::FuguVM::Console;
use App::FuguVM::Disk;
use constant {
BASE_NAME => 'base.qcow2',
META_NAME => 'meta.json',
INSTALLED_DIR => 'installed',
SNAPSHOT_DIR => 'snapshots',
TEMP_PREFIX => '.tmp.',
LOCK_PREFIX => '.lock.',
lib/App/FuguVM/DiskCache.pm view on Meta::CPAN
Fugu::File->ensure_dir( $self->installed_dir ) or return;
my $path = $self->installed_dir . '/' . LOCK_PREFIX . $key;
open my $fh, '>>', $path or do {
Fugu::Log->default->warning( 'Cannot open %s: %s', $path, $! );
return;
};
my $locked =
Fugu::Timeout::bounded( $timeout, sub { flock $fh, LOCK_EX } );
return $fh if $locked;
close $fh;
return;
}
# $self->list:
# Return every complete entry, newest first, as
# { key, dir, base, size, created_at, meta, snapshots }
sub list ($self)
lib/App/FuguVM/Guest.pm view on Meta::CPAN
use App::FuguVM::Console;
use App::FuguVM::Proxy;
use App::FuguVM::QMP;
use App::FuguVM::State;
use Fcntl qw(:flock);
use Fugu::File;
use Fugu::Random;
use Fugu::Process;
use Fugu::SSH;
use Fugu::Timeout;
use constant {
EXIT_SUCCESS => 0,
EXIT_ERROR => 1,
EXIT_CONFIG_ERROR => 3,
EXIT_VM_RUNNING => 5,
EXIT_TIMEOUT => 7,
EXIT_EXPECT_FAILED => 9,
MEMORY_DEFAULT => '1G',
lib/App/FuguVM/Guest.pm view on Meta::CPAN
# The SSH key is not installed, or it changed in the
# configuration. Use password authentication to wait for
# SSH. Then install the key.
return $self->_complete_ssh_setup;
}
# Wait for SSH. An installed VM uses key-based authentication.
$log->info("Waiting for SSH...");
if ( !$self->wait_ssh(120) ) {
$log->error("Timeout waiting for SSH");
return EXIT_TIMEOUT;
}
$log->info("VM ready");
return EXIT_SUCCESS;
}
# $self->_image_cache:
# Return the installed-image cache for this VM's configured
# cache_dir. Return undef when caching is off. 'up --no-cache'
lib/App/FuguVM/Guest.pm view on Meta::CPAN
$log->error(
"No root password stored - cannot complete SSH setup");
return EXIT_ERROR;
}
$log->info("Updating SSH key...");
# Wait for SSH with password authentication
$log->info("Waiting for SSH...");
if ( !$self->wait_ssh( 120, $root_password ) ) {
$log->error("Timeout waiting for SSH");
return EXIT_TIMEOUT;
}
# Install the SSH authorized key
if ( !$self->_install_ssh_key($root_password) ) {
$log->error("Failed to install SSH key");
return EXIT_ERROR;
}
$log->info("SSH key installed");
lib/App/FuguVM/Guest.pm view on Meta::CPAN
$log->info("Shutdown via ACPI powerdown");
return 1;
}
return 0;
}
# $self->_bounded($seconds, $code):
# Run $code under a hard wall-clock deadline, so a blocked guest
# interaction cannot stall the caller. The guard itself is
# Fugu::Timeout; this wrapper adds the log line.
sub _bounded ( $self, $seconds, $code )
{
my $result = Fugu::Timeout::bounded( $seconds, $code );
return $result if defined $result;
$self->{log}->warning("Guest did not respond within ${seconds}s");
return;
}
# $self->_ensure_proxy:
# Start the caching proxy if it does not run, and return it. The
# method returns undef when the proxy cannot start.
#
lib/App/FuguVM/Guest.pm view on Meta::CPAN
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 ) {
lib/App/FuguVM/Guest.pm view on Meta::CPAN
# $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 => $self->connect_address,
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
lib/App/FuguVM/Guest.pm view on Meta::CPAN
{
my $dir = $self->_cache_dir;
Fugu::File->ensure_dir($dir) or return;
my $path = "$dir/ports.lock";
open my $fh, '>>', $path or do {
$self->{log}->warning("Cannot open $path: $!");
return;
};
my $locked = Fugu::Timeout::bounded( PORT_LOCK_TIMEOUT,
sub { flock $fh, LOCK_EX } );
return $fh if $locked;
close $fh;
$self->{log}->warning("Port lock not acquired, probing without it");
return;
}
# $self->_check_installed_arch:
lib/App/FuguVM/Guest.pod view on Meta::CPAN
exit $vm->up;
=head1 DESCRIPTION
The module runs QEMU for an OpenBSD guest, installs the system on the
first run, and stops it again without corrupting its disk.
Everything that is not QEMU comes from Fugu. Processes and liveness
come from L<Fugu::Process>, which reaps: a QEMU that became a
zombie reads as stopped, and a caller that is about to start a second
one needs that answer. Bounded waits come from L<Fugu::Timeout>. The
random root password comes from L<Fugu::Random>. The guest
connection comes from L<Fugu::SSH>.
=head1 METHODS
=head2 new
App::FuguVM::Guest->new(config => \%vm, state => $state, log => $log, ...)
Build a controller. C<emulate> forces TCG instead of hardware
lib/App/FuguVM/Guest.pod view on Meta::CPAN
A shutdown syncs the guest filesystems first, then asks the guest to
power off through ACPI, and only then forces the process to stop.
Every step is bounded: a guest that stops answering must not hold the
caller.
The order matters. A force stop of a guest with unwritten buffers
leaves a filesystem that the next boot has to repair.
=head1 SEE ALSO
L<Fugu::Process>, L<Fugu::SSH>, L<Fugu::Timeout>,
L<App::FuguVM::Arch>, L<App::FuguVM::Disk>, L<App::FuguVM::DiskCache>,
L<App::FuguVM::QMP>, L<App::FuguVM::State>, L<fuguvm(1)>
=head1 AUTHOR
Dick Olsson <hi@senzilla.io>
man/fuguvm/fuguvm.1 view on Meta::CPAN
Invalid arguments.
.It 3
Configuration error: no project, a line that does not parse, an
invalid value, a missing or contradicting install directive, an
absent QEMU binary, or a QEMU version that does not match the pin.
.It 4
Guest not found.
.It 5
The guest runs.
.It 7
Timeout in
.Cm wait .
.It 9
An
.Xr expect 1
script failed, the install scripts included.
.It 11
Snapshot not found.
.El
.Pp
.Cm ssh
share/fuguvm/expect/autoinstall.exp view on Meta::CPAN
expect "boot>"
send "set tty com0\r"
expect "boot>"
send "boot\r"
} else {
send "\r"
}
exp_continue
}
timeout {
send_user "\n==> ERROR: Timeout waiting for installer\n"
exit 1
}
}
# The response-file location prompt
expect {
"Response file location?" {
respond $url
}
timeout {
send_user "\n==> ERROR: Timeout waiting for the response file prompt\n"
exit 1
}
eof {
send_user "\n==> ERROR: Console closed before the response file prompt\n"
exit 1
}
}
# The response file answers everything from here. Wait for the
# completion line of the installer. The set installation holds long
# silences, so this wait carries the long timeout.
set timeout [env_timeout 900]
expect {
"CONGRATULATIONS!" {
send_user "\n==> Install complete\n"
}
timeout {
send_user "\n==> ERROR: Timeout waiting for the install to finish\n"
exit 1
}
eof {
send_user "\n==> ERROR: Console closed before the install finished\n"
exit 1
}
}
# The guest now syncs its disks and reboots itself. -no-reboot makes
# QEMU exit instead, and the console then closes with an eof. The
# disk is consistent only after that exit, so the script must not
# return before it.
set timeout [env_timeout 300]
expect {
eof {
exit 0
}
timeout {
send_user "\n==> ERROR: Timeout waiting for QEMU to exit\n"
exit 1
}
}
share/fuguvm/expect/command.exp view on Meta::CPAN
send -- "$password\r"
}
"#" {
# Already logged in
}
eof {
puts stderr "telnet could not connect to the VM console"
exit 1
}
timeout {
puts stderr "Timeout waiting for prompt"
exit 1
}
}
# Wait for shell
expect "#" {
send -- "$cmd\r"
}
# Wait for command to complete
share/fuguvm/expect/install.exp view on Meta::CPAN
expect "boot>"
send "set tty com0\r"
expect "boot>"
send "boot\r"
} else {
send "\r"
}
exp_continue
}
timeout {
send_user "\n==> ERROR: Timeout waiting for installer\n"
exit 1
}
}
# Start installation
sleep 0.5
# Terminal type
expect "Terminal type?" { respond "" }
share/fuguvm/expect/install.exp view on Meta::CPAN
send_user "\n==> ERROR: The installer asked \"Continue without verification?\"\n"
send_user "==> The sets from cdn.openbsd.org did not verify in the guest\n"
exit 1
}
send_user "\n==> WARNING: The guest installs unverified sets\n"
respond "yes"
exp_continue
}
"Location of sets?" { respond "done" }
timeout {
send_user "\n==> ERROR: Timeout during set installation\n"
exit 1
}
}
# The installer asks the timezone here when its geolocation lookup
# gave no hint before the disk setup. It can also ask to correct the
# clock before it finishes. Answer both if they arrive. The (R)eboot?
# prompt marks the end of the install. Choose halt instead of reboot.
# Then fuguvm can restart from the installed disk without the
# miniroot attached. A single expect block matches every prompt. Thus
share/fuguvm/expect/install.exp view on Meta::CPAN
exp_continue
}
"Time appears wrong" {
respond "yes"
exp_continue
}
"(R)eboot?" {
respond "h"
}
timeout {
send_user "\n==> ERROR: Timeout waiting for install to finish\n"
exit 1
}
}
# The install is complete once the system halts. Do NOT wait for eof.
# OpenBSD's halt stops at the "press any key to reboot" prompt and
# does not close the console. Thus telnet stays connected and no eof
# ever arrives. fuguvm stops QEMU through QMP once this script returns.
# Then fuguvm restarts from the installed disk.
set timeout [env_timeout 120]
expect {
"The operating system has halted" { exit 0 }
"press any key to reboot" { exit 0 }
timeout {
send_user "\n==> ERROR: Timeout waiting for system halt\n"
exit 1
}
}
share/fuguvm/expect/login.exp view on Meta::CPAN
"#" {
# Already logged in
puts "Already logged in"
exit 0
}
eof {
puts stderr "telnet could not connect to the VM console"
exit 1
}
timeout {
puts stderr "Timeout waiting for login prompt"
exit 1
}
}
# Enter password
expect "Password:" {
send -- "$password\r"
}
# Wait for shell prompt
share/fuguvm/expect/login.exp view on Meta::CPAN
}
"$" {
puts "Login successful"
exit 0
}
"Login incorrect" {
puts stderr "Login failed"
exit 1
}
timeout {
puts stderr "Timeout waiting for shell"
exit 1
}
}
t/fuguvm/autoinstall.t view on Meta::CPAN
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 // '' );
}
t/fuguvm/autoinstall.t view on Meta::CPAN
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;
}
t/fuguvm/cli.t view on Meta::CPAN
# The raw form
($code) = _run_captured("--project=$project", '--quiet',
'image', 'export', "$project/out.raw", '--format=raw');
is($code, 0, 'a raw export succeeds');
like(`qemu-img info "$project/out.raw"`, qr/file format: raw/,
'and writes the raw format');
}
# A byte count for a person to read is presentation, so the CLI owns
# it. The cases came with the function from Fugu::Timeout.
subtest '_format_size' => sub {
my $f = \&App::FuguVM::CLI::_format_size;
is( $f->(0), '0B', 'zero' );
is( $f->(512), '512B', 'bytes' );
is( $f->(1023), '1023B', 'just under 1K' );
is( $f->(1024), '1.0K', 'one kilobyte' );
is( $f->(1536), '1.5K', 'one and a half' );
is( $f->(1024**2), '1.0M', 'one megabyte' );
is( $f->(1024**3), '1.0G', 'one gigabyte' );
( run in 1.432 second using v1.01-cache-2.11-cpan-85d3896f969 )