view release on metacpan or  search on metacpan

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

#	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";
		return;
	}

	Fugu::File->ensure_dir( $self->installed_dir ) or return;

	my $target = $self->entry_dir($key);
	if ( -e "$target/" . BASE_NAME ) {
		Fugu::Log->default->warning(
			'Image cache entry already exists: %s', $key );
		return;
	}

	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):
#	Return the absolute path of a named snapshot. The method does