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.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.',
	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

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

	}

	my $built = Fugu::File->atomic_dir(
		$target,
		sub ($tmp) {
			my $base = "$tmp/" . BASE_NAME;
			return 0
			    if !App::FuguVM::Disk->convert( $disk_path, $base );

			chmod 0400, $base or do {
				Fugu::Log->default->warning(
					'Cannot set permissions on %s: %s',
					$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->lock_entry($key, $timeout):
#	Return an open, exclusively locked handle on the lock file of
#	$key. The caller holds the lock until the handle closes or the
#	process exits, so a stale lock file blocks nothing. Return
#	undef when the deadline elapses, and undef when the file cannot
#	open.
#
#	The lock serializes the first population of one entry across
#	every project that shares the cache directory. It does not
#	replace the write-once rule of store: a run that lost the lock
#	to the deadline still cannot publish a second entry.
#
#	The file name starts with a dot, so it cannot collide with an
#	entry. list reads only a directory whose name has no leading
#	dot. sweep_temp removes only a '.tmp.' directory.
sub lock_entry ( $self, $key, $timeout = LOCK_TIMEOUT )
{
	return if !defined $key;

	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)
{
	my @entries;
	my $installed = $self->installed_dir;
	return \@entries if !-d $installed;

	opendir my $dh, $installed or return \@entries;
	my @keys = grep { !/^\./ && -d "$installed/$_" } readdir $dh;
	closedir $dh;

	for my $key ( sort @keys ) {
		my $entry = $self->lookup($key) or next;
		$entry->{size} = Fugu::Proxy::Cache->dir_size( $entry->{dir} );
		$entry->{created_at} = $entry->{meta}{created_at};
		$entry->{snapshots}  = $self->_snapshot_names($key);
		push @entries, $entry;
	}

	return [
		sort { ( $b->{created_at} // 0 ) <=> ( $a->{created_at} // 0 ) }
		    @entries
	];
}

# $self->key_for_path($path):
#	Return the cache key whose entry contains $path. The path can
#	point to a base image or to a snapshot. Return undef when $path
#	lies outside the cache. The method lets a caller answer "which
#	cached image is this disk built on?".
sub key_for_path ( $self, $path )
{
	return if !defined $path;

	my $installed = $self->installed_dir . '/';
	return if index( $path, $installed ) != 0;

	my ($key) = split m{/}, substr( $path, length $installed ), 2;
	return if !defined $key || $key eq '';

	return $key;
}

# $self->snapshot_dir($key):
#	Return the directory that holds the named snapshot layers of
#	an entry.
sub snapshot_dir ( $self, $key )
{
	return $self->entry_dir($key) . '/' . SNAPSHOT_DIR;
}

# $self->snapshot_path($key, $name):