vmcontrol.pl

#! /usr/bin/prun perl perl
use strict;
use warnings;
use IO::Socket::UNIX;
use JSON;
use Data::Dumper;

our $DEBUG=0;

our $s;
our $json;

sub read_json() {
	my $buffer='';
	while (1) {
		my $obj=$json->incr_parse($buffer);
		$DEBUG and defined $obj and print Data::Dumper->Dump([$obj],['RX']);
		defined $obj and return $obj;
		my $sts=sysread $s,$buffer,1024;
		$sts==0 and die "qmp.socket: hangup\n";
		defined $sts or die "qmp.socket: $!\”";
	}
}
sub write_json {
	my ($obj)=@_;
	$DEBUG and print Data::Dumper->Dump([$obj],['TX']);
	$s->print(encode_json($obj));
}

sub exec_cmd {
	my ($command,@args)=@_;
	write_json({'execute'=>$command,'arguments'=>{@args}});
	while(1) {
		my $obj=read_json();
		$obj->{'return'} and return $obj->{'return'};
	}
}

our $PATTERN=qr/^(.+)\.(\d\d\d)\.disk$/;
our %DISK;       # ( 'github_root' => [ 'ide-hd0',21 ]

sub verify_disks {
	my ($obj)=@_;
	for my $dev (@$obj) {
		my $inserted=$dev->{'inserted'} or next;
		my $device=$dev->{'device'};
		$device =~ /^ide\d+-cd\d+$/ and next;
		my $image=$inserted->{'image'};
		my $filename=$image->{'filename'};
		#printf "verify %-20s %s\n",$device,$filename;
		my ($basename,$nnn)=$filename=~$PATTERN or die "$filename: wrong pattern (expected: NAME.\\d\\d\\d.disk)\n";
		-s "$basename.disk" or die "$basename.disk: symlink is missing\n";
		readlink("$basename.disk") eq $filename or die "symlink $basename.disk not pointing to $filename\n";

		my %FILES;
		opendir my $d,".";
		while (readdir $d) {
			my ($cmp_basename,$cmp_nnn)= $_=~$PATTERN or next;
			$cmp_basename eq $basename or next;
			$FILES{$_}=1;
		}
		delete $FILES{$filename};


		my $depth=0;
		for (my $backing_image=$image->{'backing-image'};$backing_image;$backing_image=$backing_image->{'backing-image'}) {
			$depth++;
			my $b_filename=$backing_image->{'filename'};
			#printf "       %-20s %s\n",'',$b_filename;
			my ($b_basename,$b_nnn)=$b_filename=~$PATTERN or die "backing file $filename: wrong pattern\n";
			$b_basename eq $basename or die "$b_filename: wrong basename\n";
			$b_nnn == $nnn-$depth or die "$b_filename: number should be ".($nnn-$depth)."\n";
			delete $FILES{$b_filename};
		}
		if (%FILES) {
			warn "unused files: ".join(' ',keys %FILES)."\n";
		}
		$DISK{$basename}=[$device,$nnn];
	}
}

sub  verify_no_block_jobs_running {
	my $obj=exec_cmd('query-block-jobs');
	@$obj and die "block jobs running!\n";
}

sub wait_block_jobs {
	while (1) {
		my $obj=exec_cmd('query-block-jobs');
		Data::Dumper->Dump([$obj],['O']);
		@$obj or return;
		for my $job (@$obj) {
			my $device=$job->{'device'};
			my $offset=$job->{'offset'};
			my $len=$job->{'len'};
			printf "%-15s %d/%d (%5.1f%%)\n",$device,$offset,$len,$offset*100/$len;
		}
		sleep 1;
	}
}

sub snapshot {
	my ($basename)=@_;
	exists $DISK{$basename} or die "$basename does not exist in VM\n";
	my ($devname,$nnn)=@{$DISK{$basename}};
	my $filename=sprintf '%s.%03d.disk',$basename,$nnn+1;

	print "snapshot $devname -> $filename\n";
	exec_cmd('blockdev-snapshot-sync','device'=>$devname,'snapshot-file'=>$filename);
	-s "$basename.disk" and unlink "$basename.disk";
	symlink($filename,"$basename.disk") or die "failed to symlink $basename.disk -> $filename: $!\n";
	$DISK{$basename}=[$devname,$nnn+1];
}

sub block_stream {
	my ($basename)=@_;
	exists $DISK{$basename} or die "$basename does not exist in VM\n";
	my ($devname,$nnn)=@{$DISK{$basename}};
	exec_cmd('block-stream','device'=>$devname);
}


$json=new JSON;
$s=new IO::Socket::UNIX(Type=>SOCK_STREAM,Peer=>'./qmp.socket') or die "qmp.socket: $!\n";
exec_cmd('qmp_capabilities');


sub USAGE {
	<<"EOF";
usage: $0 cmd
   snapshot NAME     # new instance NAME.xxx.disk
   block-stream NAME # start stream up to top layer 
     ( hint: `fstrim -av` on the vm may save some space )
   wait              # wait till all block jobs are finished
   powerdown         # send ACPI powerdown
   noop              # do nothing, but verify disks as always
EOF
}

@ARGV or die USAGE;
my ($cmd,@args)=(@ARGV);

my $block_info=exec_cmd('query-block');
verify_disks($block_info);

if ($cmd eq 'snapshot') {
	@args==1 or die USAGE;
	verify_no_block_jobs_running();
	snapshot(@args);
} elsif ($cmd eq 'block-stream') {
	@args==1 or die USAGE;
	verify_no_block_jobs_running();
	block_stream(@args);
} elsif ($cmd eq 'wait') {
	@args==0 or die USAGE;
	wait_block_jobs();
} elsif ($cmd eq 'powerdown') {
	@args==0 or die USAGE;
	exec_cmd('system_powerdown');
} elsif ($cmd eq 'noop') {
	@args==0 or die USAGE;
} else {
	die USAGE;
}