App-FuguVM
view release on metacpan or search on metacpan
lib/App/FuguVM/CLI.pm view on Meta::CPAN
$disk->create( $vm_config->{name}, undef, $found->{path} );
if ( !defined $created ) {
$self->{log}->error("Failed to overlay snapshot '$name'");
return EXIT_ERROR;
}
# Reseed what the disk embodies. The next 'fuguvm up' reconciles
# a checkout whose SSH key differs from the saved one.
my $meta = $found->{meta};
$state->mark_installed;
$state->set_root_password( $meta->{root_password} )
if defined $meta->{root_password};
$state->mark_ssh_key_installed( $meta->{installed_ssh_pubkey} )
if defined $meta->{installed_ssh_pubkey};
$state->data->{cached_from} = "$key/$name";
$state->save;
$self->{log}->info("Restored snapshot '$name' of $key");
return EXIT_SUCCESS;
}
sub _snapshot_list ( $self, $cli, $cache, @args )
lib/App/FuguVM/Console.pm view on Meta::CPAN
sub run_install ( $self, $config )
{
my $script = $self->script_path('install.exp');
unless ( defined $script ) {
Fugu::Log->default->error('Install script not found');
return 0;
}
return $self->_expect(
$script,
$config->{root_password} // 'openbsd',
$config->{proxy_url} // 'none',
);
}
# $self->_expect($script, @args):
# Run expect(1) on the script, with the host and the port first.
# The scripts read their timeout from FUGUVM_TIMEOUT in the
# environment themselves, and each carries its own default.
#
# The run is a passthrough. An installation writes for tens of
lib/App/FuguVM/Console.pod view on Meta::CPAN
=head1 SYNOPSIS
use App::FuguVM::Console;
my $console = App::FuguVM::Console->new(
host => '127.0.0.1',
port => $console_port,
);
$console->run_install({
root_password => $password,
proxy_url => $proxy->guest_url,
}) or die "installation failed\n";
$console->run_script('reboot.exp');
=head1 DESCRIPTION
The console answers no protocol, so an L<expect(1)> script types at it.
The module runs the OpenBSD installer that way, and it runs any other
script the operator names: C<fuguvm expect> is that second verb. The
lib/App/FuguVM/Console.pod view on Meta::CPAN
Return the path of a shipped script, or C<undef>. The method also
works on the class: L<App::FuguVM::DiskCache> hashes the installer script
into its cache key, so it must resolve the script the same way
C<run_install> does.
=head2 run_install
$console->run_install(\%config)
Drive a complete installation. The configuration gives the root
password and the proxy URL that the guest fetches its sets through.
=head2 run_script
$console->run_script($script, @args)
Run one script against this console. The argument is a path, or the
name of a shipped script.
=head1 SEE ALSO
lib/App/FuguVM/DiskCache.pm view on Meta::CPAN
};
}
# $self->store($key, $disk_path, $meta):
# Publish $disk_path as the cached base image for $key. The
# method builds the entry whole in a sibling temporary directory.
# Then it publishes the entry with a rename of that directory.
# Thus no reader sees the base image of one installation beside
# the metadata of another installation. Such a mismatch would
# look live. It would then wedge every later boot with a root
# password that does not open the image.
#
# Entries are write-once: a rename onto a populated directory
# fails with ENOTEMPTY, and the existing entry wins. Return the
# base image path, or undef on any failure.
sub store ( $self, $key, $disk_path, $meta = {} )
{
return if !defined $key;
if ( !-f $disk_path ) {
warn "Cannot cache missing disk image: $disk_path\n";
lib/App/FuguVM/DiskCache.pm view on Meta::CPAN
$base, $! );
return 0;
};
my %record = (
%$meta,
key => $key,
created_at => time,
);
# The record carries the guest root password, so
# the file gets its mode before its content
return Fugu::File->write_json( "$tmp/" . META_NAME,
\%record, mode => 0600 ) ? 1 : 0;
} );
return if !defined $built;
return "$target/" . BASE_NAME;
}
# $self->list:
lib/App/FuguVM/DiskCache.pm view on Meta::CPAN
unlink $tmp_disk;
return;
}
chmod 0400, $tmp_disk or do {
warn "Cannot set permissions on $tmp_disk: $!\n";
unlink $tmp_disk;
return;
};
# The root password belongs to the base image. Thus the method
# copies it from there and does not trust the caller.
my %record = (
%$meta,
key => $key,
name => $name,
root_password => $entry->{meta}{root_password},
created_at => time,
);
# Metadata first, atomically, with the mode before the content.
# To save a name again is normal. A reader that catches the
# window sees the previous image with the new metadata. Those
# fields describe the base, which did not change.
if (
!Fugu::File->write_json(
"$dir/$name.json", \%record, mode => 0600
lib/App/FuguVM/DiskCache.pod view on Meta::CPAN
=head1 SYNOPSIS
use App::FuguVM::DiskCache;
my $cache = App::FuguVM::DiskCache->new('~/.cache/fuguvm');
my $key = $cache->key($vm_config);
# Boot from a previous installation
if (my $hit = $cache->lookup($key)) {
$disk->create($name, undef, $hit->{base});
$state->set_root_password($hit->{meta}{root_password});
}
# Publish a freshly installed disk
$cache->store($key, $disk_path, { root_password => $password });
for my $entry (@{ $cache->list }) {
printf "%s %d bytes\n", $entry->{key}, $entry->{size};
}
=head1 DESCRIPTION
An installation of OpenBSD under TCG emulation takes tens of minutes.
This module keeps the result, thus later runs do not do the
installation again. The result is a clean, compacted copy of the
lib/App/FuguVM/DiskCache.pod view on Meta::CPAN
<cache_dir>/installed/<key>/base.qcow2 mode 0400
<cache_dir>/installed/<key>/meta.json mode 0600
<cache_dir>/installed/<key>/snapshots/<name>.qcow2 mode 0400
<cache_dir>/installed/<key>/snapshots/<name>.json mode 0600
The entries are immutable and write-once. C<store> builds a full entry
in a sibling C<.tmp.*> directory, and then it publishes the entry with
a rename of that directory. Thus a reader never sees the base image of
one installation adjacent to the metadata of a different installation.
Such a mismatch looks live, but it then stops every later boot,
because the root password does not open the image.
=head2 Cache keys
C<key> returns C<< <version>-<arch>-<hash8> >>. C<hash8> is a
truncated SHA-256 over each input that shapes an installed disk. These
inputs are:
=over 4
=item * the OpenBSD version
lib/App/FuguVM/DiskCache.pod view on Meta::CPAN
=item lookup($key)
The method returns C<< { key, dir, base, meta } >> for a complete
entry. In other cases, it returns C<undef>. A half-written entry is a
miss, not an error.
=item store($key, $disk_path, $meta)
The method compacts C<$disk_path> into the cache as the base image
for C<$key>, and writes C<$meta> adjacent to it. Put the guest
C<root_password> in C<$meta>. The method returns the path of the base
image. It returns C<undef> on a failure, and a try to overwrite a
populated key is one such failure. The caller then degrades to a
standalone disk.
=item list
The method returns each complete entry, newest first, as
C<< { key, dir, base, meta, size, created_at, snapshots } >>.
=item remove($key)
lib/App/FuguVM/DiskCache.pod view on Meta::CPAN
alphanumeric character, it must hold only word characters, dots, and
dashes, and it must have a bounded length.
=item snapshot_store($key, $name, $disk_path, $meta)
The method flattens the stopped working disk at C<$disk_path> onto
the base image of C<$key>, and publishes the result as the named
layer. Put the state fields that the disk holds in C<$meta>:
C<installed> and the installed SSH public key. With these fields, a
restore can reseed L<App::FuguVM::State>. The method copies the root
password from the metadata of the base itself, and it does not trust
the caller for this value. The method returns the snapshot path, or
C<undef> on a failure.
When a caller saves the same name again, the method replaces the
snapshot. This is the normal second run of a provisioning script.
=item snapshot_lookup($key, $name)
The method returns C<< { key, name, path, base, meta } >> for a
snapshot whose image, metadata, and backing chain all resolve. In
lib/App/FuguVM/DiskCache.pod view on Meta::CPAN
The method deletes a snapshot and its metadata. Deletion in any order
is safe, because each snapshot is a direct child of the base, never
of a different snapshot.
=back
=head1 SECURITY
F<meta.json> is mode 0600, and it holds the generated guest root
password, the same secret that the VM state directory keeps. The cache
makes the life of this secret longer: the password stays after
C<fuguvm destroy>, and it changes only when the base key changes.
The guest permits root login with a password. QEMU forwards the SSH
port and the serial console port of the guest on each host interface.
Thus the password is not a localhost-only secret. See L<fuguvm(1)>.
=head1 SEE ALSO
L<App::FuguVM::Disk>, L<App::FuguVM::Console>, L<App::FuguVM::Miniroot>, L<App::FuguVM::Guest>,
L<fuguvm(1)>
=cut
lib/App/FuguVM/Guest.pm view on Meta::CPAN
# Install the system if necessary
if ( !$state->is_installed ) {
# The proxy already runs. The code above started it for the
# image download. Use the VM-accessible URL for the
# installation. The VM connects to the host through the
# gateway.
my $install_proxy_url = $proxy_vm_url // 'none';
# Generate a strong random password for this installation
my $root_password = Fugu::Random->random_password(32);
$state->set_root_password($root_password);
$log->info("Generated secure root password");
$log->info("Installing OpenBSD...");
my $expect = App::FuguVM::Console->new(
host => '127.0.0.1',
port => $config->{console_port},
);
# Use the generated password for the installation
my $install_config = {
%$config,
root_password => $root_password,
proxy_url => $install_proxy_url,
};
my $ok = $expect->run_install($install_config);
if ( !$ok ) {
$log->error("Installation failed");
return EXIT_ERROR;
}
$state->mark_installed;
$log->info("Installation complete");
lib/App/FuguVM/Guest.pm view on Meta::CPAN
$self->_wait_exit(10);
}
$state->clear_vm_pid;
# Publish the installed disk as a cached base image. A VM
# that was force stopped can leave the disk mid-write. Thus
# the code skips that capture and does not publish it.
if ( defined $cache_key ) {
if ($clean_exit) {
$self->_cache_store( $cache, $cache_key,
$root_password );
}
else {
$log->warning(
"Skipping image cache: installation VM was force stopped"
);
}
}
# Restart the VM without the install media
$log->info("Restarting installed system...");
lib/App/FuguVM/Guest.pm view on Meta::CPAN
# Install the SSH authorized key for future key-based
# authentication
return $self->_complete_ssh_setup;
}
# The VM is installed. Check if the SSH key must be installed or
# updated.
if ( $self->_needs_ssh_key_update ) {
# 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;
}
lib/App/FuguVM/Guest.pm view on Meta::CPAN
$disk->create( $config->{name}, undef, $hit->{base} );
if ( !defined $path ) {
$log->warning(
"Cannot overlay cached image $key, installing instead");
return 0;
}
# The base was captured from an installed system. Thus the state
# that the installer would have written comes from the metadata
# of the base. The later SSH key install authenticates with the
# root password. That password is baked into the image.
$state->mark_installed;
my $password = $hit->{meta}{root_password};
$state->set_root_password($password) if defined $password;
$state->data->{cached_from} = $key;
$state->save;
$log->info("Using cached image $key");
return 1;
}
# $self->_cache_store($cache, $key, $root_password):
# Publish the freshly installed disk as a cached base image. Then
# replace the working disk with an overlay on that image. The
# operation is best effort. On any failure it keeps the
# standalone disk in place and warns. 'up' must never fail
# because caching failed.
sub _cache_store ( $self, $cache, $key, $root_password )
{
my $config = $self->{config};
my $state = $self->{state};
my $log = $self->{log};
$log->info("Caching installed image as $key...");
my $base = $cache->store(
$key,
$state->disk_path,
{
root_password => $root_password,
version => $config->{version},
disk_size => $config->{disk_size},
} );
if ( !defined $base ) {
$log->warning("Could not cache installed image, continuing");
return 0;
}
if ( !$self->_reparent_disk($base) ) {
$log->warning(
lib/App/FuguVM/Guest.pm view on Meta::CPAN
sub ssh_port ($self)
{
return $self->{config}{ssh_port};
}
sub console_port ($self)
{
return $self->{config}{console_port};
}
# $self->wait_ssh($timeout, $password):
# Wait for SSH to become available. Without a password, the
# connection uses the SSH agent for authentication. The initial
# installation gives the root password, because the SSH key is
# not in yet.
sub wait_ssh ( $self, $timeout = 120, $password = undef )
{
my $ssh = Fugu::SSH->new(
host => '127.0.0.1',
port => $self->{config}{ssh_port},
user => 'root',
( defined $password ? ( password => $password ) : () ),
);
return $ssh->wait_available($timeout);
}
# $self->_needs_ssh_key_update:
# Check if the SSH key must be installed or updated. Return true
# if no key is installed. Also return true if the configured key
# differs from the installed key.
sub _needs_ssh_key_update ($self)
lib/App/FuguVM/Guest.pm view on Meta::CPAN
# Compare the keys. Normalize the whitespace for the comparison.
my $configured_normalized = $configured_key =~ s/\s+/ /gr;
my $installed_normalized = $installed_key =~ s/\s+/ /gr;
return $configured_normalized ne $installed_normalized;
}
# $self->_complete_ssh_setup():
# Install or update the SSH key on the VM. The method
# authenticates with the stored root password. It runs to recover
# from a failed first boot, or when the configured SSH key
# changed.
sub _complete_ssh_setup ($self)
{
my $state = $self->{state};
my $config = $self->{config};
my $log = $self->{log};
my $root_password = $state->get_root_password;
if ( !defined $root_password ) {
$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");
$log->info("VM ready");
return EXIT_SUCCESS;
}
# $self->_install_ssh_key($password):
# Install the SSH public key from the configuration into
# authorized_keys. The method uses password authentication,
# because the key is not yet installed.
sub _install_ssh_key ( $self, $password )
{
my $config = $self->{config};
my $state = $self->{state};
my $log = $self->{log};
# Get the SSH public key from the configuration
my $ssh_pubkey = $config->{ssh_pubkey};
if ( !defined $ssh_pubkey || $ssh_pubkey eq '' ) {
$log->error("No ssh_pubkey configured in ~/.fuguvmrc");
return 0;
}
# Connect with the password
my $ssh = Fugu::SSH->new(
host => '127.0.0.1',
port => $config->{ssh_port},
user => 'root',
password => $password,
);
# Create the .ssh directory
my $result =
$ssh->run_command('mkdir -p /root/.ssh && chmod 700 /root/.ssh');
if ( $result->{exit_code} != 0 ) {
return 0;
}
# Write the authorized_keys file
lib/App/FuguVM/Guest.pod view on Meta::CPAN
=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
acceleration; C<no_cache> ignores the installed-image cache.
lib/App/FuguVM/Guest.pod view on Meta::CPAN
=head2 down, destroy, start, stop, status
C<down> stops the proxy and then the VM, gracefully, and records a
clean shutdown. C<destroy> stops it and deletes the disk. C<start> and
C<stop> are the narrow forms that do not touch the proxy. C<status>
reports the state.
=head2 wait_ssh, ssh_port, console_port, is_running
C<wait_ssh> polls until the guest takes an authenticated connection;
with a password argument it authenticates with that password instead
of the SSH agent. C<console_port> is the port that C<telnet> reaches
the serial console on.
=head1 SHUTDOWN
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.
lib/App/FuguVM/State.pm view on Meta::CPAN
sub mark_installed ($self)
{
$self->{store}->data->{installed} = 1;
$self->{store}->data->{installed_at} = time;
$self->{store}->save;
return $self;
}
# Root password management. The state stores the password for the
# initial setup. The store writes at mode 0600.
sub set_root_password ( $self, $password )
{
$self->{store}->set( root_password => $password );
return $self;
}
sub get_root_password ($self)
{
return $self->{store}->get('root_password');
}
# SSH key installation state
# The state tracks which SSH key is installed. Thus the system can
# detect when the configured SSH key changed. Then it automatically
# installs the new key.
sub mark_ssh_key_installed ( $self, $ssh_pubkey = undef )
{
my $data = $self->{store}->data;
$data->{ssh_key_installed} = 1;
lib/App/FuguVM/State.pod view on Meta::CPAN
=head2 disk_path, disk_exists
The working disk of the VM.
=head2 is_installed, mark_installed
Whether OpenBSD is installed on the disk. An installed system boots
its own disk and never attaches the miniroot again.
=head2 set_root_password, get_root_password
The password that the installer set. The store writes at mode 0600.
=head2 mark_ssh_key_installed, get_installed_ssh_pubkey
Which SSH public key the guest holds. The state records the key
itself, not only that there is one. Thus a key that changed in the
configuration is installed again on the next C<fuguvm up>.
=head2 mark_running, mark_clean_shutdown, mark_unclean_shutdown, was_unclean_shutdown, clear_shutdown_state
Whether the last stop was clean. C<was_unclean_shutdown> also reports
man/fuguvm/fuguvm.1 view on Meta::CPAN
utility was first available in 2025.
Its initial purpose was to run the test suite of a daemon against a
real
.Ox
guest.
It became more general from there.
.Sh AUTHORS
.An Dick Olsson Aq Mt hi@senzilla.io
.Sh SECURITY CONSIDERATIONS
.Nm
generates a random root password for each installation and stores it
in the VM state directory.
When the installed image goes into the cache,
.Nm
also stores the password in the
.Pa meta.json
of that entry
.Pq mode 0600 .
The cache makes the life of this secret longer:
the password stays after
.Cm destroy ,
and it changes only when the base key changes.
.Pp
This is not a localhost-only secret.
The guest permits password root login.
.Nm
gives QEMU the
.Ar ssh_port
and
.Ar console_port
values with no bind address.
Thus the forwarded SSH port and the telnet serial console listen on
each host interface.
Treat a VM that runs as open to all persons who can reach the host.
Apply the same rule to a
share/fuguvm/expect/command.exp view on Meta::CPAN
#!/usr/bin/expect -f
#
# Run a single command on the console and exit
#
# Usage: command.exp <host> <port> <command> [user] [password]
#
# Use the environment variable when it exists. Otherwise use 60.
if {[info exists env(FUGUVM_TIMEOUT)]} {
set timeout $env(FUGUVM_TIMEOUT)
} else {
set timeout 60
}
if {[llength $argv] < 3} {
puts stderr "Usage: command.exp <host> <port> <command> \[user\] \[password\]"
exit 1
}
set host [lindex $argv 0]
set port [lindex $argv 1]
set cmd [lindex $argv 2]
set user [lindex $argv 3]
set password [lindex $argv 4]
if {$user eq ""} {
set user "root"
}
if {$password eq ""} {
set password "openbsd"
}
# Connect to console
spawn telnet $host $port
# Send a newline to trigger login prompt
send "\r"
# Wait for login prompt or shell
expect {
"login:" {
send "$user\r"
expect "Password:"
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"
share/fuguvm/expect/install.exp view on Meta::CPAN
#!/usr/bin/expect -f
#
# Automated OpenBSD installation over the serial console
#
# Usage: install.exp <host> <port> [root_password] [proxy_url]
#
# Use FUGUVM_TIMEOUT from the environment when it exceeds the
# script default. Slow hosts need this, for example under TCG
# emulation in CI.
proc env_timeout {default} {
global env
if {[info exists env(FUGUVM_TIMEOUT)] && $env(FUGUVM_TIMEOUT) > $default} {
return $env(FUGUVM_TIMEOUT)
}
return $default
}
set timeout [env_timeout 300]
if {[llength $argv] < 2} {
puts stderr "Usage: install.exp <host> <port> \[root_password\] \[proxy_url\]"
exit 1
}
set host [lindex $argv 0]
set port [lindex $argv 1]
set root_password [lindex $argv 2]
set proxy_url [lindex $argv 3]
if {$root_password eq ""} {
set root_password "openbsd"
}
if {$proxy_url eq ""} {
set proxy_url "none"
}
log_user 1
# Helper proc to send a response after a match
proc respond {response} {
share/fuguvm/expect/install.exp view on Meta::CPAN
# IPv6 address
expect "IPv6 address" { respond "none" }
# Done with network interfaces
expect "Network interface to configure?" { respond "done" }
# Password for root. Wait for the actual prompt.
expect "Password for root account?"
sleep 0.5
send "$root_password\r"
expect "Password for root account? (again)"
sleep 0.5
send "$root_password\r"
# Start sshd
expect "Start sshd(8)" { respond "yes" }
# Setup a user
expect "Setup a user?" { respond "no" }
# Allow root ssh login
expect "Allow root ssh login?" { respond "yes" }
share/fuguvm/expect/login.exp view on Meta::CPAN
#!/usr/bin/expect -f
#
# Simple login automation for OpenBSD VM
#
# Usage: login.exp <host> <port> [user] [password]
#
# Use FUGUVM_TIMEOUT from the environment when it exceeds the
# script default. Slow hosts need this, for example under TCG
# emulation in CI.
proc env_timeout {default} {
global env
if {[info exists env(FUGUVM_TIMEOUT)] && $env(FUGUVM_TIMEOUT) > $default} {
return $env(FUGUVM_TIMEOUT)
}
return $default
}
set timeout [env_timeout 30]
if {[llength $argv] < 2} {
puts stderr "Usage: login.exp <host> <port> \[user\] \[password\]"
exit 1
}
set host [lindex $argv 0]
set port [lindex $argv 1]
set user [lindex $argv 2]
set password [lindex $argv 3]
if {$user eq ""} {
set user "root"
}
if {$password eq ""} {
set password "openbsd"
}
# Connect to console
spawn telnet $host $port
# Send a newline to trigger login prompt
send "\r"
# Wait for login prompt
expect {
share/fuguvm/expect/login.exp view on Meta::CPAN
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
expect {
"#" {
puts "Login successful"
exit 0
}
"$" {
puts "Login successful"
t/fuguvm/cli.t view on Meta::CPAN
my $has_qemu = `which qemu-img 2>/dev/null`;
skip 'qemu-img not installed', 4 unless $has_qemu;
my $project = _cache_project();
my $cache = App::FuguVM::DiskCache->new("$project/cache");
my $key = '7.8-arm64-cafebabe';
my $source = "$project/source.qcow2";
system('qemu-img', 'create', '-f', 'qcow2', $source, '16M') == 0
or skip 'cannot create a test disk image', 4;
my $base = $cache->store($key, $source, { root_password => 'pw' });
# A working disk in this checkout, backed by the cached entry
my $state_dir = "$project/.fuguvm/state";
App::FuguVM::Disk->new($state_dir)->create('default', undef, $base);
# This test process stands in for a live QEMU
make_path("$state_dir/default");
open my $pidfh, '>', "$state_dir/default/vm.pid" or die $!;
print $pidfh "$$\n";
close $pidfh;
t/fuguvm/cli.t view on Meta::CPAN
$disk->create('default', '16M');
my $state = App::FuguVM::State->new($state_dir, 'default');
$state->mark_installed;
local $SIG{__WARN__} = sub {};
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'save', 'deps'),
1, 'a standalone disk is a diagnosed error, not a crash');
# Rebuild the disk as an overlay on a cached base
my $base = $cache->store($key, $source, { root_password => 'pw' });
unlink $disk->path('default');
$disk->create('default', undef, $base);
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'save', 'deps'),
0, 'save succeeds on a disk backed by a cached image');
ok(defined $cache->snapshot_lookup($key, 'deps'), 'the snapshot exists');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'list'),
t/fuguvm/cli.t view on Meta::CPAN
# Restore from nothing. No disk and no state exist, as in a
# fresh checkout.
unlink $disk->path('default');
unlink "$state_dir/default/status";
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'restore', 'deps'),
0, 'restore works with no disk and no state');
my $reseeded = App::FuguVM::State->new($state_dir, 'default');
ok($reseeded->is_installed, 'restore reseeds installed state');
is($reseeded->get_root_password, 'pw',
'restore reseeds the root password from the base');
# A running VM refuses both save and restore
open my $pidfh, '>', "$state_dir/default/vm.pid" or die $!;
print $pidfh "$$\n";
close $pidfh;
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'save', 'deps'),
5, 'save refuses while the VM is running');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
t/fuguvm/cli.t view on Meta::CPAN
my $has_qemu = `which qemu-img 2>/dev/null`;
skip 'qemu-img not installed', 4 unless $has_qemu;
my $project = _cache_project();
my $cache = App::FuguVM::DiskCache->new("$project/cache");
my $key = $cache->key(App::FuguVM::Config->new($project)->load_vm('default'));
my $source = "$project/source.qcow2";
system('qemu-img', 'create', '-f', 'qcow2', $source, '16M') == 0
or skip 'cannot create a test disk image', 4;
my $base = $cache->store($key, $source, { root_password => 'pw' });
App::FuguVM::Disk->new("$project/.fuguvm/state")
->create('default', undef, $base);
App::FuguVM::State->new("$project/.fuguvm/state", 'default')->mark_installed;
is(_capture_stdout($project, 'snapshot', 'list', '--names'), '',
'nothing on stdout when there are no snapshots');
App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'save', 'deps-aaa');
App::FuguVM::CLI->run("--project=$project", '--quiet',
t/fuguvm/cli.t view on Meta::CPAN
{
my ($cache, $key) = @_;
my $dir = $cache->entry_dir($key);
make_path($dir);
open my $bh, '>', "$dir/base.qcow2" or die $!;
print $bh 'not a real image';
close $bh;
open my $mh, '>', "$dir/meta.json" or die $!;
print $mh qq({"key":"$key","created_at":1,"root_password":"pw"});
close $mh;
return $dir;
}
t/fuguvm/diskcache.t view on Meta::CPAN
my $cache = App::FuguVM::DiskCache->new("$tmp/cache");
my $key = '7.8-arm64-abcd1234';
my $disk = "$tmp/disk.qcow2";
system( 'qemu-img', 'create', '-f', 'qcow2', $disk, '64M' )
== 0
or skip 'cannot create a test disk image', 19;
# Store an entry. Look it up again.
my $base = $cache->store( $key, $disk,
{ root_password => 's3cret', version => '7.8' } );
ok( defined $base, 'store returns the published base image path' );
is( $base, $cache->base_path($key), 'stored at the expected path' );
ok( -f $base, 'base image exists' );
is( sprintf( '%04o', ( stat $base )[2] & 07777 ),
'0400', 'base image is read-only' );
is(
sprintf( '%04o',
( stat $cache->entry_dir($key) . '/meta.json' )[2]
& 07777 ),
'0600',
'metadata is owner-only: it holds the root password'
);
my $hit = $cache->lookup($key);
ok( defined $hit, 'lookup hits after store' );
is( $hit->{meta}{root_password},
's3cret', 'the root password round-trips' );
is( $hit->{meta}{key}, $key, 'metadata echoes the key' );
ok( $hit->{meta}{created_at} > 0, 'metadata records a creation time' );
# The base is a real, self-standing qcow2
my $out = qx{qemu-img info --output=json "$base" 2>/dev/null};
my $info = eval { JSON::XS::decode_json($out) };
is( $info->{format}, 'qcow2', 'the base is a qcow2 image' );
ok( !defined $info->{'backing-filename'},
'the base stands alone: no backing file of its own' );
# Listing
my $entries = $cache->list;
is( scalar @$entries, 1, 'list finds the entry' );
is( $entries->[0]{key}, $key, 'list reports the key' );
ok( $entries->[0]{size} > 0, 'list reports a size' );
is_deeply( $entries->[0]{snapshots}, [], 'no snapshots yet' );
# Write-once: a second store must not replace a populated entry
my $again = do {
local $SIG{__WARN__} = sub { };
$cache->store( $key, $disk, { root_password => 'other' } );
};
is( $again, undef, 'store refuses to overwrite a populated key' );
is( $cache->lookup($key)->{meta}{root_password},
's3cret', 'the original entry survives the refusal' );
# A failed store leaves no temporary tree behind
my $failed = do {
local $SIG{__WARN__} = sub { };
$cache->store( 'other-key', "$tmp/no-such-disk.qcow2", {} );
};
is( $failed, undef, 'store of a missing disk fails' );
my $orphans = _temp_trees( $cache->installed_dir );
t/fuguvm/diskcache.t view on Meta::CPAN
require App::FuguVM::Disk;
my $tmp = tempdir( CLEANUP => 1 );
my $cache = App::FuguVM::DiskCache->new("$tmp/cache");
my $key = '7.8-arm64-0f0f0f0f';
my $source = "$tmp/source.qcow2";
system( 'qemu-img', 'create', '-f', 'qcow2', $source, '64M' ) == 0
or skip 'cannot create a test disk image', 5;
my $base = $cache->store( $key, $source, { root_password => 'pw' } );
ok( defined $base, 'base image published' );
my $disk = App::FuguVM::Disk->new("$tmp/state");
my $path = $disk->create( 'default', undef, $base );
ok( defined $path, 'overlay created without an explicit size' );
is( $disk->backing_file('default'),
$base, 'the overlay is backed by the cached base' );
my $info = $disk->info('default');
t/fuguvm/diskcache.t view on Meta::CPAN
require App::FuguVM::Disk;
my $tmp = tempdir( CLEANUP => 1 );
my $cache = App::FuguVM::DiskCache->new("$tmp/cache");
my $key = '7.8-arm64-5a5a5a5a';
my $source = "$tmp/source.qcow2";
system( 'qemu-img', 'create', '-f', 'qcow2', $source, '64M' ) == 0
or skip 'cannot create a test disk image', 16;
my $base = $cache->store( $key, $source, { root_password => 'pw' } );
# A working overlay, the shape a snapshot comes from
my $disk = App::FuguVM::Disk->new("$tmp/state");
$disk->create( 'default', undef, $base );
my $disk_path = $disk->path('default');
is( $cache->snapshot_lookup( $key, 'deps' ),
undef, 'no snapshot before one is saved' );
is_deeply( $cache->snapshot_list($key), [], 'and none listed' );
my $path = $cache->snapshot_store( $key, 'deps', $disk_path,
{ installed => 1, installed_ssh_pubkey => 'ssh-ed25519 AAA' } );
ok( defined $path, 'snapshot_store publishes a layer' );
is( sprintf( '%04o', ( stat $path )[2] & 07777 ),
'0400', 'the snapshot image is read-only' );
my $found = $cache->snapshot_lookup( $key, 'deps' );
ok( defined $found, 'snapshot_lookup hits' );
is( $found->{meta}{installed_ssh_pubkey},
'ssh-ed25519 AAA', 'state fields round-trip' );
is( $found->{meta}{root_password},
'pw', 'the root password is taken from the base, not the caller' );
is( _backing($path), $base, 'the snapshot hangs off base.qcow2' );
is( scalar @{ $cache->snapshot_list($key) }, 1, 'snapshot_list finds it' );
is_deeply( $cache->list->[0]{snapshots},
['deps'], 'cache listing counts it' );
# A re-save from a disk restored FROM the snapshot must not
# make the snapshot its own parent. It must not stack chains
# without bound.
t/fuguvm/diskcache.t view on Meta::CPAN
SKIP: {
skip 'qemu-img not installed', 3 if !$HAS_QEMU_IMG;
my $tmp = tempdir( CLEANUP => 1 );
my $cache = App::FuguVM::DiskCache->new("$tmp/cache");
my $key = '7.8-arm64-6b6b6b6b';
my $source = "$tmp/source.qcow2";
system( 'qemu-img', 'create', '-f', 'qcow2', $source, '64M' ) == 0
or skip 'cannot create a test disk image', 3;
my $base = $cache->store( $key, $source, { root_password => 'pw' } );
ok( defined $cache->snapshot_store( $key, 'layer', $source, {} ),
'a snapshot exists' );
unlink $base;
is( $cache->snapshot_lookup( $key, 'layer' ),
undef, 'it reads as a miss once its base is gone' );
my $orphan = do {
local $SIG{__WARN__} = sub { };
t/fuguvm/guest.t view on Meta::CPAN
my $root = tempdir(CLEANUP => 1);
my $cache = App::FuguVM::DiskCache->new("$root/cache");
my $key = '7.8-arm64-11223344';
# A stand-in for a freshly installed disk
my $installed = "$root/installed.qcow2";
system('qemu-img', 'create', '-f', 'qcow2', $installed, '64M') == 0
or skip 'cannot create a test disk image', 14;
my $base = $cache->store($key, $installed,
{ root_password => 'from-the-image' });
ok(defined $base, 'a base image is available to restore from');
my $state = App::FuguVM::State->new("$root/state", 'default');
my $vm = App::FuguVM::Guest->new(
config => { name => 'default', cache_dir => "$root/cache" },
state => $state,
log => TestLog->new,
);
# Restore: the overlay plus the state that the installation
# leaves behind
ok($vm->_cache_restore($cache, $key), 'restore reports a cache hit');
ok($state->disk_exists, 'the working disk exists after a restore');
ok($state->is_installed, 'the restored VM is marked installed');
is($state->get_root_password, 'from-the-image',
'the root password comes from the image, not a new install');
is($state->data->{cached_from}, $key,
'state records which cached image it came from');
my $disk = App::FuguVM::Disk->new("$root/state");
is($disk->backing_file('default'), $base,
'the working disk is an overlay on the cached base');
# A resolvable chain passes verification
ok($vm->_verify_backing_chain, 'an intact backing chain verifies');
t/fuguvm/state.t view on Meta::CPAN
# Test disk paths
{
my $tmpdir = tempdir(CLEANUP => 1);
my $state = App::FuguVM::State->new($tmpdir, 'test');
like($state->disk_path, qr/disk\.qcow2$/, 'disk_path ends with disk.qcow2');
ok(!$state->disk_exists, 'disk_exists returns false when no disk');
}
# Test root password management
{
my $tmpdir = tempdir(CLEANUP => 1);
my $state = App::FuguVM::State->new($tmpdir, 'test');
is($state->get_root_password, undef, 'No password initially');
$state->set_root_password('testpass123');
is($state->get_root_password, 'testpass123', 'Password stored and retrieved');
# Reload the state and make sure that the value persists
my $state2 = App::FuguVM::State->new($tmpdir, 'test');
is($state2->get_root_password, 'testpass123', 'Password persisted');
}
# Test SSH key installation state
{
my $tmpdir = tempdir(CLEANUP => 1);
my $state = App::FuguVM::State->new($tmpdir, 'test');
is($state->get_installed_ssh_pubkey, undef, 'No pubkey stored initially');
my $test_pubkey = 'ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAI... test@example';
( run in 2.607 seconds using v1.01-cache-2.11-cpan-4ef0a570458 )