view release on metacpan or  search on metacpan

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

# $self->_require_port($vm, $directive):
#	Return the resolved port of the guest, or undef with a
#	diagnostic. A stopped guest with a directive of 'auto' has no
#	port, and a connection with an undef port would reach the
#	default port of the protocol on the host itself.
sub _require_port ( $self, $vm, $directive )
{
	my $port = $directive eq 'ssh_port' ? $vm->ssh_port : $vm->console_port;
	return $port if defined $port;

	$self->{log}->error( "VM '$self->{vm_name}' has no $directive now."
		    . " Run 'fuguvm up' first." );
	return;
}

# $self->_require_running($vm):
#	Return 1 while the guest runs. Log one line and return 0
#	otherwise, because a clear message beats a "Failed to connect"
#	from libssh2.
sub _require_running ( $self, $vm )
{
	return 1 if $vm->is_running;

	$self->{log}->error( "VM '$self->{vm_name}' does not run."
		    . " Run 'fuguvm up' first." );
	return 0;
}

# $self->_require_remote($vm, $directive):
#	Return the App::FuguVM::Remote object of the guest, or undef.
#	The guest must run, and the port of $directive must resolve.
#	_require_running and _require_port each log the reason.
sub _require_remote ( $self, $vm, $directive )
{
	return if !$self->_require_running($vm);

	my $port = $self->_require_port( $vm, $directive );
	return if !defined $port;

	# The connection uses the SSH agent for authentication. Connect
	# to the IPv4 address that the forwarded port binds to. A name
	# such as 'localhost' resolves to ::1 first on a dual-stack
	# host, and QEMU does not listen there.
	return App::FuguVM::Remote->new(
		host => $vm->connect_address,
		port => $port,
	);
}

# Open an SSH session into the VM, or run one argument vector on it
sub cmd_ssh ( $self, $cli, @args )
{
	my $vm = $self->_load_vm or return $self->{load_exit};

	my $remote = $self->_require_remote( $vm, 'ssh_port' );
	return EXIT_ERROR if !defined $remote;

	if (@args) {
		my $result = $remote->run(@args);
		print $result->{stdout}        if $result->{stdout};
		print STDERR $result->{stderr} if $result->{stderr};
		return $result->{exit_code};
	}
	else {
		return $remote->interactive;
	}
}

# Copy a local file or a local directory into the guest
sub cmd_put ( $self, $cli, @args )
{
	my ( $local, $remote_path, @extra ) = @args;
	if ( !defined $local || !defined $remote_path || @extra ) {
		$self->{log}->error(
			'Usage: fuguvm put [--mode=<octal>] <local> <remote>');
		return EXIT_INVALID_ARGS;
	}
	if ( index( $remote_path, '/' ) != 0 ) {
		$self->{log}
		    ->error("The remote path is not absolute: $remote_path");
		return EXIT_INVALID_ARGS;
	}

	my $mode = $cli->option('mode');
	if ( defined $mode && $mode !~ /^[0-7]{3,4}$/ ) {
		$self->{log}->error(
			"Invalid --mode value: $mode (3 or 4 octal digits)");
		return EXIT_INVALID_ARGS;
	}
	if ( -l $local || ( !-f $local && !-d $local ) ) {
		$self->{log}
		    ->error("Not a regular file or a directory: $local");
		return EXIT_INVALID_ARGS;
	}

	my $vm = $self->_load_vm or return $self->{load_exit};

	my $remote = $self->_require_remote( $vm, 'ssh_port' );
	return EXIT_ERROR if !defined $remote;

	return EXIT_ERROR
	    if !$remote->put( $local, $remote_path,
		defined $mode ? ( mode => oct($mode) ) : () );

	return EXIT_SUCCESS;
}

# Copy one guest file to the host
sub cmd_get ( $self, $cli, @args )
{
	my ( $remote_path, $local, @extra ) = @args;
	if ( !defined $remote_path || !defined $local || @extra ) {
		$self->{log}->error('Usage: fuguvm get <remote> <local>');
		return EXIT_INVALID_ARGS;
	}
	if ( index( $remote_path, '/' ) != 0 ) {
		$self->{log}
		    ->error("The remote path is not absolute: $remote_path");
		return EXIT_INVALID_ARGS;
	}
	if ( -d $local ) {

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

{
	my $vm    = $self->_load_vm or return $self->{load_exit};
	my $state = $self->{state};

	if ( $vm->is_running ) {
		$self->{log}->error("Stop the VM before restoring a snapshot");
		return EXIT_VM_RUNNING;
	}

	my $key = $self->_current_cache_key($cache)
	    or return EXIT_ERROR;

	my $found = $self->_snapshot_found( $cache, $key, $name )
	    or return EXIT_SNAPSHOT_NOT_FOUND;

	# Disk::create returns early on an existing path. Without this
	# removal, a restore would report success and change nothing.
	my $disk_path = $state->disk_path;
	if ( -f $disk_path ) {
		unlink $disk_path or do {
			$self->{log}->error("Cannot remove $disk_path: $!");
			return EXIT_ERROR;
		};
	}

	my $vm_config = $self->{config}->load_vm( $self->{vm_name} );
	my $disk      = App::FuguVM::Disk->new( $self->{config}->state_dir );
	my $created =
	    $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( $vm_config->{arch} );
	$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 )
{
	my $names = $cli->option('names') // 0;

	my $key = $self->_current_cache_key($cache)
	    or return EXIT_ERROR;

	my $snapshots = $cache->snapshot_list($key);

	# --names writes bare names to stdout, where a shell can read
	# them. The human listing goes through the logger, which writes
	# to stderr and prefixes every line.
	if ($names) {
		say $_->{name} for @$snapshots;
		return EXIT_SUCCESS;
	}

	if ( !@$snapshots ) {
		$self->{log}->info("No snapshots for $key");
		return EXIT_SUCCESS;
	}

	for my $snapshot (@$snapshots) {
		my $created =
		    defined $snapshot->{created_at}
		    ? scalar localtime $snapshot->{created_at}
		    : 'unknown';
		$self->{log}->info(
			sprintf( '  - %s  %s  %s',
				$snapshot->{name},
				_format_size( $snapshot->{size} ),
				$created ) );
	}

	return EXIT_SUCCESS;
}

sub _snapshot_remove ( $self, $cache, $name )
{
	my $key = $self->_current_cache_key($cache)
	    or return EXIT_ERROR;

	$self->_snapshot_found( $cache, $key, $name )
	    or return EXIT_SNAPSHOT_NOT_FOUND;

	if ( !$cache->snapshot_remove( $key, $name ) ) {
		return EXIT_ERROR;
	}

	$self->{log}->info("Removed snapshot '$name'");
	return EXIT_SUCCESS;
}

# $self->_snapshot_found($cache, $key, $name):
#	Look a snapshot up. Diagnose a miss, once for every caller.
sub _snapshot_found ( $self, $cache, $key, $name )
{
	my $found = $cache->snapshot_lookup( $key, $name );

	$self->{log}->error("No snapshot '$name' for $key")
	    if !defined $found;

	return $found;
}

# $self->_disk_cache_key($cache):
#	Return the cache entry that backs the working disk, directly
#	with its base image or through a snapshot of it.
sub _disk_cache_key ( $self, $cache )
{
	my $vm_config = $self->{config}->load_vm( $self->{vm_name} );
	return if !defined $vm_config;