view release on metacpan or  search on metacpan

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

# ex:ts=8 sw=4:
# $OpenBSD$
#
# Copyright (c) 2026 Dick Olsson <hi@dickolsson.com>
#
# 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::DiskCache - cache of installed OpenBSD disks.
#
# An OpenBSD installation under TCG emulation costs tens of minutes.
# This module keeps the result: a pristine, compacted copy of the disk,
# taken the moment the installer finished. Later runs use that copy as
# the backing image of a throwaway overlay.
#
# The module caches the disk. App::FuguVM::Miniroot caches the install
# media that produced it. Neither is a cache of the other.

package App::FuguVM::DiskCache;
our $VERSION = '0.2.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.',
	LOCK_TIMEOUT       => 3600,
	GENERATION_FILE    => 'cache-generation',
	INSTALL_SCRIPT     => 'install.exp',
	AUTOINSTALL_SCRIPT => 'autoinstall.exp',
	KEY_HASH_LENGTH    => 8,
	MAX_SNAPSHOT_NAME  => 128,
};

sub new ( $class, $cache_dir )
{
	my $self =
	    bless { cache_dir => Fugu::File->expand_tilde($cache_dir), },
	    $class;

	return $self;
}

# $self->installed_dir:
#	Return the directory that holds every cached entry.
sub installed_dir ($self)
{
	return "$self->{cache_dir}/" . INSTALLED_DIR;
}

# $self->entry_dir($key):
#	Return the directory of one cached entry.
sub entry_dir ( $self, $key )
{
	return $self->installed_dir . "/$key";
}

# $self->base_path($key):
#	Return the absolute path of the base image of an entry. The
#	method does not check that the image exists.
sub base_path ( $self, $key )
{
	return $self->entry_dir($key) . '/' . BASE_NAME;
}

# $self->key($vm_config):
#	Derive the cache key for a VM configuration:
#	<version>-<arch>-<hash8>. The hash covers each input that
#	shapes an installed disk, and it covers nothing else. Thus
#	memory and port changes keep hitting the same entry. The
#	record follows the install mode, because each mode shapes the
#	disk with different inputs:
#
#	expect       version, arch, disk_size, the digest of
#	             install.exp, the digest of the generation file
#	autoinstall  version, arch, disk_size, the digest of
#	             autoinstall.exp, the digest of the response file,
#	             the digest of the generation file
#	import       version, arch, the digest of the generation file
#
#	An import runs no script, and its overlay inherits the virtual
#	size of the base. Thus the import record holds no script digest
#	and no disk_size, and an imported entry survives a change to a
#	shipped expect script. Return undef when an input cannot be
#	read. Then the caller has no key and thus no caching.
sub key ( $self, $vm_config )
{
	if ( !defined $vm_config->{arch} ) {
		warn "Cannot derive a cache key without an architecture\n";
		return;
	}

	my $version = _sanitize( $vm_config->{version} // '' );
	my $arch    = _sanitize( $vm_config->{arch} );
	my $mode    = $vm_config->{install_mode} // 'expect';

	my @inputs = ( "version=$version", "arch=$arch" );