view release on metacpan or  search on metacpan

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

	my $installer = Fugu::File->read($script);
	return if !defined $installer;

	my $generation_file = $self->_generation_file;
	if ( !defined $generation_file ) {
		warn "Cannot locate " . GENERATION_FILE . " for cache key\n";
		return;
	}

	my $generation = Fugu::File->read($generation_file);
	return if !defined $generation;

	# Hash the file contents separately. Thus the joined record
	# stays free of newlines, and an input value cannot forge the
	# delimiter.
	my @inputs = (
		"version=$version",
		"arch=$arch",
		"disk_size=$disk_size",
		'install=' . Digest::SHA::sha256_hex($installer),
		'generation=' . Digest::SHA::sha256_hex($generation),
	);

	my $hash = Digest::SHA::sha256_hex( join( "\n", @inputs ) );

	return "$version-$arch-" . substr( $hash, 0, KEY_HASH_LENGTH );
}

# $self->lookup($key):
#	Return { base => path, meta => hashref, dir => path } for a
#	complete entry, or undef otherwise. A half-written entry is a
#	miss, not an error. The caller falls back to a full
#	installation.
sub lookup ( $self, $key )
{
	return if !defined $key;

	my $dir  = $self->entry_dir($key);
	my $base = "$dir/" . BASE_NAME;
	return if !-f $base;

	my $meta = Fugu::File->read_json( "$dir/" . META_NAME );
	return if !defined $meta;

	return {
		key  => $key,
		dir  => $dir,
		base => $base,
		meta => $meta,
	};
}

# $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";
		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 !_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->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;

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

	return 0 if $name !~ /^[A-Za-z0-9][\w.-]*$/;

	return 1;
}

# $self->snapshot_store($key, $name, $disk_path, $meta):
#	Publish the stopped working disk as the named snapshot layer of
#	entry $key.
#
#	The method flattens the disk onto base.qcow2 and does not copy
#	it. A copy would carry the backing-file header of the working
#	disk verbatim. That header is only correct while the disk hangs
#	directly off the base. After a restore the disk hangs off a
#	snapshot. Thus a copy would stack chains without bound. A
#	normal second run saves the same name again. Then a copy would
#	name itself as its own backing file. The flatten operation also
#	keeps every snapshot a direct child of the base. Thus no
#	snapshot is the parent of another snapshot, and the removal of
#	one snapshot cannot orphan another.
#
#	Return the snapshot path, or undef on failure.
sub snapshot_store ( $self, $key, $name, $disk_path, $meta = {} )
{
	if ( !$self->valid_snapshot_name($name) ) {
		warn "Invalid snapshot name: " . ( $name // '(undef)' ) . "\n";
		return;
	}

	my $entry = $self->lookup($key);
	if ( !defined $entry ) {
		warn "No cached image for $key to snapshot against\n";
		return;
	}

	if ( !-f $disk_path ) {
		warn "Cannot snapshot missing disk image: $disk_path\n";
		return;
	}

	my $dir = $self->snapshot_dir($key);
	Fugu::File->ensure_dir($dir) or return;

	# qemu-img writes the image, so the atomic file helpers cannot
	# carry it. It goes through one temporary path and one rename.
	my $target   = $self->snapshot_path( $key, $name );
	my $tmp_disk = "$target." . TEMP_PREFIX . $$;

	unlink $tmp_disk;

	if ( !_convert( $disk_path, $tmp_disk, $entry->{base} ) ) {
		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
		) )
	{
		unlink $tmp_disk;
		return;
	}
	if ( !rename $tmp_disk, $target ) {
		warn "Cannot publish snapshot $name: $!\n";
		unlink $tmp_disk;
		return;
	}

	return $target;
}

# $self->snapshot_lookup($key, $name):
#	Return { key, name, path, meta } for a snapshot whose image,
#	metadata, and backing chain all resolve. Return undef
#	otherwise. A snapshot whose base was removed is a miss. Thus a
#	caller can fall back to a provision from scratch and does not
#	fail hard.
sub snapshot_lookup ( $self, $key, $name )
{
	return if !$self->valid_snapshot_name($name);

	my $path = $self->snapshot_path( $key, $name );
	return if !-f $path;

	my $meta =
	    Fugu::File->read_json( $self->snapshot_dir($key) . "/$name.json" );
	return if !defined $meta;

	my $base = $self->base_path($key);
	return if !-f $base;

	return {
		key  => $key,
		name => $name,
		path => $path,
		base => $base,
		meta => $meta,
	};
}

# $self->snapshot_list($key):
#	Return the sorted snapshots of an entry, as
#	{ name, path, size, created_at }
sub snapshot_list ( $self, $key )
{
	my @snapshots;