App-FuguVM
15 results

 view release on metacpan or  search on metacpan

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

		$self->{error} = sprintf 'no free port in %d-%d', @{ +PORTS };
		return;
	}

	my $child  = ref $self;
	my $result = Fugu::Process->spawn_perl(
		code      => "use $child; $child->run_child(\@ARGV)",
		args      => [ $port, $self->{file}, $self->{proxy_url} // '' ],
		daemonize => 1,
		stdout    => $self->{logfile},
		stderr    => $self->{logfile},
	);
	unless ( $result->{success} ) {
		$self->{error} = "cannot start the responder: $result->{error}";
		return;
	}

	$self->{pidfile}->write_pid( $result->{pid} );
	$self->{store}->set( autoinstall_port => $port );

	unless ( $self->_wait_ready ) {

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


	return 1;
}

# $class->run_child($port, $file, $proxy_url):
#	The entry point of the spawned child. The child reads the
#	response file, renders it, and serves it until a SIGTERM. It
#	logs each request line, and it never logs the file content.
sub run_child ( $class, $port, $file, $proxy_url )
{
	my $log = Fugu::Log->new( mode => 'stderr', level => 'debug' );

	my $bytes = Fugu::File->read($file);
	die "Cannot read the response file: $file\n" if !defined $bytes;

	my $body = $class->render( $bytes, $proxy_url );

	my $listener = IO::Socket::INET->new(
		LocalAddr => BIND_ADDRESS,
		LocalPort => $port,
		Proto     => 'tcp',

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

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 )
{

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

{
	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;
	}

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

	push @cmd, $path;
	push @cmd, $size if defined $size;

	# The capture also swallows the verbose "Formatting..." line of
	# qemu-img, which no caller wants to see
	my $result = Fugu::Process->run( cmd => \@cmd );

	unless ( $result->{success} ) {
		Fugu::Log->default->error( 'Failed to create disk image %s: %s',
			$path,
			$result->{stderr} || $result->{error} || 'unknown' );
		return;
	}

	return $path;
}

sub path ( $self, $name )
{
	return "$self->{state_dir}/$name/disk.qcow2";
}

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


	my @cmd = ( 'qemu-img', 'convert', '-O', $format );
	push @cmd, '-B', $opts{backing}, '-F', 'qcow2'
	    if defined $opts{backing};
	push @cmd, $source, $target;

	my $result = Fugu::Process->run( cmd => \@cmd );
	unless ( $result->{success} ) {
		Fugu::Log->default->error( 'Failed to convert %s to %s: %s',
			$source, $target,
			$result->{stderr} || $result->{error} || 'unknown' );
		return;
	}

	return $target;
}

# $self->info($name):
#	Get the qemu-img report on the disk as a hashref. The method
#	returns undef when there is no disk or when it cannot read the
#	disk. The inspection is read-only. Thus it asks for shared

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

# P5: Check the disk image integrity. The method returns a hashref
# with the 'status' and 'output' keys. The 'status' key is 'ok' or
# 'corrupted'.
sub check ( $self, $name )
{
	my $path = $self->path($name);
	return if !-f $path;

	my $result =
	    Fugu::Process->run( cmd => [ 'qemu-img', 'check', $path ] );
	my $output = $result->{stdout} . $result->{stderr};

	return {
		status => $result->{success} ? 'ok' : 'corrupted',
		output => $output,
		path   => $path,
	};
}

# P5: Repair the disk image. The method returns true on success and
# false on failure.

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


	# No graphics display (headless)
	push @cmd, '-display', 'none';

	# Use Fugu::Process to spawn QEMU
	my $log_file = $state->vm_state_dir . '/qemu.log';
	my $result   = Fugu::Process->spawn_command(
		cmd       => \@cmd,
		daemonize => 1,
		stdout    => $log_file,
		stderr    => $log_file,
	);

	return unless $result->{success};

	# Wait until QEMU writes the PID file
	my $pid = Fugu::Timeout::wait_until(
		5, 0.1,
		sub {
			my $qemu_pid = $state->get_vm_pid;
			return $qemu_pid

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

# $class->run_child($port, $cache_dir):
#	The entry point of the spawned child. The child builds its own
#	cache, warms the metadata, and serves until a SIGTERM.
#
#	The spawn passes a fixed argument list, so the distfile cap
#	reaches the child through the environment, which it inherits
#	from fuguvm. An absent variable means 0, and 0 turns the
#	distfile cache off.
sub run_child ( $class, $port, $cache_dir )
{
	my $log = Fugu::Log->new( mode => 'stderr', level => 'debug' );

	my $limit = $ENV{FUGUVM_DISTFILE_LIMIT} // 0;
	$limit = 0 if $limit !~ /\A[0-9]+\z/;

	my $self = bless {
		cache => App::FuguVM::Proxy::Cache->new( $cache_dir, $limit ),
		meta  => Fugu::Proxy::Meta->new,
		log   => $log,
	}, $class;

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

	while (@dirs) {
		my @batch = splice @dirs, 0, BATCH_PATHS;
		my $result =
		    $self->{ssh}
		    ->run_command( $self->quote_argv( 'mkdir', '-p', @batch ) );

		if ( $result->{exit_code} != 0 ) {
			Fugu::Log->default->error(
				'Cannot create directories on %s:%d: %s',
				$self->{host}, $self->{port},
				$result->{stderr} );
			return;
		}
	}

	return 1;
}

# $self->_publish(@files):
#	Move every temporary file onto its destination, with batched
#	mv -f commands. Each mv holds two paths, so one batch holds

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

		my @batch   = splice @pairs, 0, int( BATCH_PATHS / 2 );
		my $command = join ' && ',
		    map { $self->quote_argv( 'mv', '-f', $_->[0], $_->[1] ) }
		    @batch;

		my $result = $self->{ssh}->run_command($command);
		if ( $result->{exit_code} != 0 ) {
			Fugu::Log->default->error(
				'Cannot publish files on %s:%d: %s',
				$self->{host}, $self->{port},
				$result->{stderr} );
			return;
		}
	}

	return 1;
}

# $self->_discard(@temps):
#	Remove the temporary files that a failed put wrote, with
#	batched rm -f commands. The removal is best effort: the

lib/App/FuguVM/Remote.pod  view on Meta::CPAN 

each word in single quotes, and it replaces each single quote inside
a word with the C<'\''> form. An empty word becomes C<''>. The words
join with one space. So the remote shell splits the string at the
word boundaries only: it expands nothing, and it globs nothing.

=head2 run

    $remote->run(@argv)

Run one argument vector on the guest. The method returns the hash of
C<< Fugu::SSH->run_command >>: C<stdout>, C<stderr> and C<exit_code>.
It dies on an empty vector. A connect failure reads as exit code 1,
with the reason in C<stderr>.

=head2 interactive

    $remote->interactive

Open an interactive session. The method returns the exit code of
L<ssh(1)>.

=head2 put

share/fuguvm/expect/autoinstall.exp  view on Meta::CPAN 

        return $env(FUGUVM_TIMEOUT)
    }
    return $default
}

set timeout [env_timeout 300]

set usage "Usage: autoinstall.exp <host> <port> <url> <arch>"

if {[llength $argv] != 4} {
    puts stderr $usage
    exit 1
}

set host [lindex $argv 0]
set port [lindex $argv 1]
set url [lindex $argv 2]
set arch [lindex $argv 3]

if {$url eq ""} {
    puts stderr $usage
    exit 1
}

# The configuration loader of fuguvm validates the value, so this
# exit guards a manual run only.
if {$arch ne "amd64" && $arch ne "arm64"} {
    puts stderr $usage
    exit 1
}

log_user 1

# Helper proc to send a response after a match
proc respond {response} {
    sleep 0.5
    send "$response\r"
}

share/fuguvm/expect/command.exp  view on Meta::CPAN 

#

# Use the environment variable when it exists. Otherwise use 60.
if {[info exists env(FUGUVM_TIMEOUT)]} {
    set timeout $env(FUGUVM_TIMEOUT)
} else {
    set timeout 60
}

if {[llength $argv] < 3} {
    puts stderr "Usage: command.exp <host> <port> <command> \[user\] \[password\]"
    exit 1
}

set host [lindex $argv 0]
set port [lindex $argv 1]
set cmd [lindex $argv 2]
set user [lindex $argv 3]
set password [lindex $argv 4]

if {$user eq ""} {

share/fuguvm/expect/command.exp  view on Meta::CPAN 

expect {
    "login:" {
        send "$user\r"
        expect "Password:"
        send "$password\r"
    }
    "#" {
        # Already logged in
    }
    eof {
        puts stderr "telnet could not connect to the VM console"
        exit 1
    }
    timeout {
        puts stderr "Timeout waiting for prompt"
        exit 1
    }
}

# Wait for shell
expect "#" {
    send "$cmd\r"
}

# Wait for command to complete

share/fuguvm/expect/install.exp  view on Meta::CPAN 

        return $env(FUGUVM_TIMEOUT)
    }
    return $default
}

set timeout [env_timeout 300]

set usage "Usage: install.exp <host> <port> <root_password> <proxy_url> <arch> <verify>"

if {[llength $argv] != 6} {
    puts stderr $usage
    exit 1
}

set host [lindex $argv 0]
set port [lindex $argv 1]
set root_password [lindex $argv 2]
set proxy_url [lindex $argv 3]
set arch [lindex $argv 4]
set verify [lindex $argv 5]

share/fuguvm/expect/install.exp  view on Meta::CPAN 

    set root_password "openbsd"
}

if {$proxy_url eq ""} {
    set proxy_url "none"
}

# The configuration loader of fuguvm validates the value, so this
# exit guards a manual run only.
if {$arch ne "amd64" && $arch ne "arm64"} {
    puts stderr $usage
    exit 1
}

# The configuration loader also normalizes the verify switch.
if {$verify ne "yes" && $verify ne "no"} {
    puts stderr $usage
    exit 1
}

log_user 1

# Helper proc to send a response after a match
proc respond {response} {
    sleep 0.5
    send "$response\r"
}

share/fuguvm/expect/login.exp  view on Meta::CPAN 

    global env
    if {[info exists env(FUGUVM_TIMEOUT)] && $env(FUGUVM_TIMEOUT) > $default} {
        return $env(FUGUVM_TIMEOUT)
    }
    return $default
}

set timeout [env_timeout 30]

if {[llength $argv] < 2} {
    puts stderr "Usage: login.exp <host> <port> \[user\] \[password\]"
    exit 1
}

set host [lindex $argv 0]
set port [lindex $argv 1]
set user [lindex $argv 2]
set password [lindex $argv 3]

if {$user eq ""} {
    set user "root"

share/fuguvm/expect/login.exp  view on Meta::CPAN 

expect {
    "login:" {
        send "$user\r"
    }
    "#" {
        # Already logged in
        puts "Already logged in"
        exit 0
    }
    eof {
        puts stderr "telnet could not connect to the VM console"
        exit 1
    }
    timeout {
        puts stderr "Timeout waiting for login prompt"
        exit 1
    }
}

# Enter password
expect "Password:" {
    send "$password\r"
}

# Wait for shell prompt
expect {
    "#" {
        puts "Login successful"
        exit 0
    }
    "$" {
        puts "Login successful"
        exit 0
    }
    "Login incorrect" {
        puts stderr "Login failed"
        exit 1
    }
    timeout {
        puts stderr "Timeout waiting for shell"
        exit 1
    }
}

t/fuguvm/cli.t  view on Meta::CPAN 

	0, 'bare cache clear succeeds');
    is(scalar @{ $proxy->list }, 0, 'bare clear empties the proxy too');
}

# The listing also reports the proxy. Thus a user who decides on a
# prune sees both halves of cache_dir.
{
    my $project = _cache_project();
    _fake_download($project, '7.7/arm64/base77.tgz');

    my $err = _capture_stderr($project, 'cache', 'list');
    like($err, qr/Proxy downloads/, 'cache list reports the proxy store');
    like($err, qr/OpenBSD 7\.7/, 'broken down by version');
    like($err, qr/No cached images/,
	'and still says the images are empty');
    unlike($err, qr/Distfiles/, 'an empty distfile tree has no line');
}

# The distfile line of cache list: the size against the cap, or the
# size with a note that the cap is off. A distfile never joins the
# per-version grouping, because it carries no version.
{
    my $project = _cache_project("distfile_cache 4G\n");
    _fake_download($project, '7.8/arm64/base78.tgz');
    _fake_distfile($project, 'gmake-4.4.1.tar.gz');

    my $err = _capture_stderr($project, 'cache', 'list');
    like($err, qr/Distfiles: \d+B of 4\.0G/,
	'cache list reports the distfile size and the cap');
    is(scalar(grep { /OpenBSD -/ } split /\n/, $err), 0,
	'no distfile lands in the version grouping');

    my $off = _cache_project();
    _fake_distfile($off, 'gmake-4.4.1.tar.gz');
    $err = _capture_stderr($off, 'cache', 'list');
    like($err, qr/Distfiles: \d+B, caching off/,
	'a tree with a cap of 0 reads as caching off');
}

# cache clear --stale keeps the distfile tree and re-applies the cap;
# a bare clear removes the tree with everything else
{
    my $project = _cache_project("distfile_cache 4G\n");
    _fake_download($project, '7.7/arm64/base77.tgz');
    my $distfile = _fake_distfile($project, 'gmake-4.4.1.tar.gz');

t/fuguvm/cli.t  view on Meta::CPAN 

	    'snapshot', 'restore', 'deps'),
	5, 'restore refuses while the VM is running');
    unlink "$state_dir/default/vm.pid";

    is(App::FuguVM::CLI->run("--project=$project", '--quiet',
	    'snapshot', 'rm', 'deps'),
	0, 'rm succeeds');
}

# --names is the scriptable listing. It writes bare names on stdout,
# where a shell can read them. It does not go through the stderr logger.
SKIP: {
    my $has_qemu = `which qemu-img 2>/dev/null`;
    skip 'qemu-img not installed', 4 unless $has_qemu;

    my $project = _cache_project();
    my $cache = App::FuguVM::DiskCache->new("$project/cache");
    my $key = $cache->key(App::FuguVM::Config->new($project)->load_vm('default'));

    my $source = "$project/source.qcow2";
    system('qemu-img', 'create', '-f', 'qcow2', $source, '16M') == 0

t/fuguvm/cli.t  view on Meta::CPAN 

    print $fh "vm \"default\" {\n";
    print $fh "\tversion 7.8\n";
    print $fh "\tdisk_size 8G\n";
    print $fh "}\n";
    close $fh;

    return $project;
}

# Run a command with both streams captured, and return the exit
# code, the stdout text and the stderr text. Thus scriptable output
# cannot mix with the TAP stream of this test. The capture goes
# through real files, never through an in-memory scalar: a scalar
# handle has no file descriptor, and the output of a child process
# would then land wherever descriptor 1 points at that moment.
sub _run_captured
{
    my (@args) = @_;
    my $dir = tempdir(CLEANUP => 1);

    open my $saved_out, '>&', \*STDOUT or die $!;

t/fuguvm/cli.t  view on Meta::CPAN 


    open STDOUT, '>&', $saved_out or die $!;
    close $saved_out;
    open STDERR, '>&', $saved_err or die $!;
    close $saved_err;

    return ($code, _slurp("$dir/out"), _slurp("$dir/err"));
}

# Run a command and capture stdout. This separates the scriptable
# output from the logger's stderr.
sub _capture_stdout
{
    my ($project, @args) = @_;
    my (undef, $out) =
	_run_captured("--project=$project", '--quiet', @args);

    return $out;
}

# The logger writes to stderr. Thus this helper captures the human
# listing apart from the scriptable output above.
sub _capture_stderr
{
    my ($project, @args) = @_;
    my (undef, undef, $err) = _run_captured("--project=$project", @args);

    return $err;
}

# _slurp($path):
#	The whole file as text.
sub _slurp

t/fuguvm/config.t  view on Meta::CPAN 

    }

    # An unrecognized value must not silently mean its opposite
    open $fh, '>', "$tmpdir/.fuguvmrc";
    print $fh "image_cache maybe\n";
    close $fh;
    my $diagnostic = '';
    my $result;
    {
	local *STDERR;
	open STDERR, '>', \$diagnostic or die "capture stderr: $!";
	$result = App::FuguVM::Config->new($tmpdir)->image_cache;
    }
    is($result, 1, 'an unparseable image_cache falls back to the default');
    like($diagnostic, qr/not a yes\/no value: maybe/,
	'and it says so instead of meaning the opposite');
}

# The distfile_cache directive: the size grammar, the default, the
# refusal, and the merge
{

t/fuguvm/config.t  view on Meta::CPAN 

    is($write->("cache_dir /tmp\n")->distfile_cache, 0,
	'an absent directive is off');

    # An unparsable value warns and reads as off: an unrecognized
    # spelling must not silently mean its opposite, and off is the
    # closed state for a cache.
    my $diagnostic = '';
    my $result;
    {
	local *STDERR;
	open STDERR, '>', \$diagnostic or die "capture stderr: $!";
	$result = $write->("distfile_cache lots\n")->distfile_cache;
    }
    is($result, 0, 'an unparsable distfile_cache is off');
    like($diagnostic, qr/lots/, 'and the warning names the value');

    # The project file wins over the global file, for each of the
    # three directives of the mirror work
    open my $gh, '>', "$homedir/.fuguvmrc" or die $!;
    print $gh "distfile_cache 1K\n";
    print $gh "verify yes\n";

t/fuguvm/config.t  view on Meta::CPAN 

    open $fh, '>', "$tmpdir/.fuguvmrc";
    print $fh "distfile_cache 4G\n";
    print $fh "vm test {\n";
    print $fh "    distfile_cache 8G\n";
    print $fh "}\n";
    close $fh;
    my $warning = '';
    my $loaded;
    {
	local *STDERR;
	open STDERR, '>', \$warning or die "capture stderr: $!";
	$loaded = App::FuguVM::Config->new($tmpdir)->load_vm('test');
    }
    is($loaded->{distfile_cache}, 4 * 1024**3,
	'the project cap wins over a cap in a VM block');
    like($warning, qr/distfile_cache/,
	'and the loader warns about the block value');
}

# The parser normalizes image_cache inside a vm block like the global
# directive

t/fuguvm/mirror.t  view on Meta::CPAN 

	'ensure returns the cached path with no fetch');
}

# With verify set to 0, ensure stores the file and logs one warning,
# and the proof methods refuse: a method must not report a proof that
# it did not make.
{
    my $cache_dir = tempdir(CLEANUP => 1);
    my $mirror = _mirror($cache_dir, verify => 0);

    my $warned = _capture_stderr(sub {
	no warnings 'redefine';
	local *App::FuguVM::Mirror::fetch =
	    sub ($, $) { _temp_file('unproven bytes') };
	is($mirror->ensure('release', 'base78.tgz'),
	    _cache($cache_dir)->cache_path(
		'https://cdn.openbsd.org/pub/OpenBSD/7.8/arm64/base78.tgz'),
	    'ensure with verify 0 stores the file');
    });
    like($warned, qr/unproven/i, 'and it logs one warning');

t/fuguvm/mirror.t  view on Meta::CPAN 

    my ($path) = @_;

    open my $fh, '<', $path or die "read $path: $!";
    local $/;
    my $bytes = <$fh>;
    close $fh;

    return $bytes;
}

# _capture_stderr($code):
#	Run the code with the process default logger on standard
#	error, capture the stream, and put the quiet default back.
sub _capture_stderr
{
    my ($code) = @_;
    my $dir = tempdir(CLEANUP => 1);

    Fugu::TestLog->stderr;
    open my $saved, '>&', \*STDERR or die $!;
    open STDERR, '>', "$dir/err" or die $!;

    $code->();

    open STDERR, '>&', $saved or die $!;
    close $saved;
    Fugu::TestLog->quiet;

    return _slurp("$dir/err");

t/fuguvm/remote.t  view on Meta::CPAN 


# A mock transport. The batching tests read the commands that put
# would run, without a guest.
package Mock::SSH {
    sub new ($class) {
	return bless { commands => [], writes => [] }, $class;
    }

    sub run_command ($self, $command) {
	push @{ $self->{commands} }, $command;
	return { stdout => '', stderr => '', exit_code => 0 };
    }

    sub write_file ($self, $path, $content, $mode) {
	push @{ $self->{writes} }, [ $path, $mode ];
	return 0;
    }
}

# ============================================================
# quote_argv



( run in 1.596 second using v1.01-cache-2.11-cpan-5c0b1e786e0 )