Add vmcontrol.pl

Import existing script vmcontrol.pl to repository and install it into
/usr/bin.

The script currently lives in ~vmprj/bin and is used by multiple
projects. we don't want to have a nfs dependency for this script, so
just install it into the system.

After the planned move of ~vmprj into /var, ~vmprj/bin wouldn't no
longer be a good place for scripts, too.

install.sh

@@ -222,6 +222,7 @@ install_data mxshadow/mxshadow.cert.pem                   "$DESTDIR$sysconfdir/m
 install_data mxshadow/mxshadow.conf                       "$DESTDIR$sysconfdir/mxshadow.conf"
 install_data mxshadow/mxshadow.service                    "$DESTDIR$systemdunitdir/mxshadow.service"
 install_data misc_etc_files/nsswitch.conf                 "$DESTDIR$sysconfdir/nsswitch.conf"
+install_exec vmcontrol/vmcontrol.pl                       "$DESTDIR$usr_bindir/vmcontrol.pl"
 
 postinstall
 exit

vmcontrol/vmcontrol.pl

@@ -0,0 +1,164 @@
+#! /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;
+}