mirror of
https://git.proxmox.com/git/qemu-server
synced 2025-08-04 21:35:05 +00:00
use new QMPClient code
This commit is contained in:
Dietmar Maurer
parent
30a3378acd
commit
26f11676c7
2
Makefile
2
Makefile
@ -2,7 +2,7 @@ RELEASE=2.1
|
||||
|
||||
VERSION=2.0
|
||||
PACKAGE=qemu-server
|
||||
PKGREL=42
|
||||
PKGREL=43
|
||||
|
||||
DESTDIR=
|
||||
PREFIX=/usr
|
||||
|
||||
@ -1,7 +1,11 @@
|
||||
PERLSOURCE = \
|
||||
QemuServer.pm \
|
||||
QemuMigrate.pm \
|
||||
QMPClient.pm
|
||||
|
||||
.PHONY: install
|
||||
install:
|
||||
install -D -m 0644 QemuServer.pm ${DESTDIR}${PERLDIR}/PVE/QemuServer.pm
|
||||
install -D -m 0644 QemuMigrate.pm ${DESTDIR}${PERLDIR}/PVE/QemuMigrate.pm
|
||||
install -d ${DESTDIR}${PERLDIR}/PVE
|
||||
install -m 0644 ${PERLSOURCE} ${DESTDIR}${PERLDIR}/PVE/
|
||||
make -C VZDump install
|
||||
make -C API2 install
|
||||
134
PVE/QMPClient.pm
134
PVE/QMPClient.pm
@ -1,5 +1,3 @@
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
package PVE::QMPClient;
|
||||
|
||||
use strict;
|
||||
@ -91,9 +89,6 @@ my $close_connection = sub {
|
||||
delete $self->{fhs_lookup}->{$fh};
|
||||
|
||||
$self->{mux}->close($fh);
|
||||
|
||||
print "CLOSE SOCKET to $vmid\n";
|
||||
|
||||
};
|
||||
|
||||
my $open_connection = sub {
|
||||
@ -104,8 +99,6 @@ my $open_connection = sub {
|
||||
my $fh = IO::Socket::UNIX->new(Peer => $sname, Blocking => 0, Timeout => 1) ||
|
||||
die "unable to connect to VM $vmid socket - $!\n";
|
||||
|
||||
print "OPEN SOCKET to $vmid \n";
|
||||
|
||||
$self->{fhs}->{$vmid} = $fh;
|
||||
$self->{fhs_lookup}->{$fh} = $vmid;
|
||||
$self->{mux}->add($fh);
|
||||
@ -147,12 +140,10 @@ my $check_queue = sub {
|
||||
arguments => $cmd->{arguments},
|
||||
id => $cmd->{id}});
|
||||
|
||||
print "WRITECMD:$vmid: $qmpcmd\n";
|
||||
$self->{mux}->write($fh, $qmpcmd);
|
||||
};
|
||||
if (my $err = $@) {
|
||||
$self->{errors}->{$vmid} = $err;
|
||||
# fixme: close fh?
|
||||
} else {
|
||||
$running++;
|
||||
}
|
||||
@ -169,8 +160,6 @@ sub queue_execute {
|
||||
|
||||
$timeout = 3 if !$timeout;
|
||||
|
||||
print "start exec queue\n";
|
||||
|
||||
$self->{current} = {};
|
||||
$self->{errors} = {};
|
||||
|
||||
@ -207,9 +196,6 @@ sub queue_execute {
|
||||
}
|
||||
|
||||
$self->{queue} = $self->{current} = $self->{fhs} = $self->{fhs_lookup} = {};
|
||||
|
||||
print "end exec queue $running\n";
|
||||
|
||||
}
|
||||
|
||||
# mux_input is called when input is available on one of
|
||||
@ -217,8 +203,6 @@ sub queue_execute {
|
||||
sub mux_input {
|
||||
my ($self, $mux, $fh, $input) = @_;
|
||||
|
||||
print "GOT: $$input\n";
|
||||
|
||||
return if $$input !~ m/}\r\n$/;
|
||||
|
||||
my $raw = $$input;
|
||||
@ -246,11 +230,6 @@ sub mux_input {
|
||||
next;
|
||||
}
|
||||
|
||||
# die $obj->{error}->{desc} if defined($obj->{error}->{desc});
|
||||
|
||||
#print "GOTOBJ: " . Dumper($obj);
|
||||
|
||||
# we do not need events for now
|
||||
if (defined($obj->{event})) {
|
||||
if (my $eventcb = $self->{eventcb}) {
|
||||
&$eventcb($obj);
|
||||
@ -287,121 +266,10 @@ sub mux_timeout {
|
||||
my ($self, $mux, $fh) = @_;
|
||||
|
||||
if (my $vmid = $self->{fhs_lookup}->{$fh}) {
|
||||
|
||||
print "GOT timeout for $vmid\n";
|
||||
|
||||
$self->{errors}->{$vmid} = "got timeout\n";
|
||||
}
|
||||
|
||||
&$check_queue($self);
|
||||
}
|
||||
|
||||
|
||||
|
||||
package test;
|
||||
|
||||
use strict;
|
||||
use PVE::SafeSyslog;
|
||||
use PVE::INotify;
|
||||
use PVE::QemuServer;
|
||||
use PVE::Cluster;
|
||||
use Data::Dumper;
|
||||
|
||||
initlog($0);
|
||||
|
||||
$ENV{'PATH'} = '/sbin:/bin:/usr/sbin:/usr/bin';
|
||||
|
||||
die "please run as root\n" if $> != 0;
|
||||
|
||||
PVE::INotify::inotify_init();
|
||||
|
||||
my $nodename = PVE::INotify::nodename();
|
||||
|
||||
sub vm_qmp_command {
|
||||
my ($vmid, $cmd, $nocheck) = @_;
|
||||
|
||||
my $res;
|
||||
|
||||
eval {
|
||||
die "VM $vmid not running\n" if !PVE::QemuServer::check_running($vmid, $nocheck);
|
||||
|
||||
my $qmpclient = PVE::QMPClient->new();
|
||||
|
||||
$res = $qmpclient->cmd($vmid, $cmd);
|
||||
|
||||
};
|
||||
if (my $err = $@) {
|
||||
syslog("err", "VM $vmid qmp command failed - $err");
|
||||
die $err;
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
# print Dumper(vm_qmp_command(100, { execute => 'query-status' }));
|
||||
|
||||
sub update_qemu_stats {
|
||||
|
||||
print "start update\n";
|
||||
|
||||
my $ctime = time();
|
||||
|
||||
my $vmstatus = PVE::QemuServer::vmstatus();
|
||||
|
||||
my $qmpclient = PVE::QMPClient->new();
|
||||
|
||||
my $res = {};
|
||||
|
||||
my $blockstatscb = sub {
|
||||
my ($vmid, $resp) = @_;
|
||||
my $data = $resp->{'return'} || [];
|
||||
my $totalrdbytes = 0;
|
||||
my $totalwrbytes = 0;
|
||||
for my $blockstat (@$data) {
|
||||
$totalrdbytes = $totalrdbytes + $blockstat->{stats}->{rd_bytes};
|
||||
$totalwrbytes = $totalwrbytes + $blockstat->{stats}->{wr_bytes};
|
||||
}
|
||||
$res->{$vmid}->{diskread} = $totalrdbytes;
|
||||
$res->{$vmid}->{diskwrite} = $totalwrbytes;
|
||||
};
|
||||
|
||||
my $statuscb = sub {
|
||||
my ($vmid, $resp) = @_;
|
||||
$qmpclient->queue_cmd($vmid, $blockstatscb, 'query-blockstats');
|
||||
|
||||
my $status = 'unknown';
|
||||
if (!defined($status = $resp->{'return'}->{status})) {
|
||||
warn "unable to get VM status\n";
|
||||
return;
|
||||
}
|
||||
|
||||
$res->{$vmid}->{status} = $resp->{'return'}->{status};
|
||||
};
|
||||
|
||||
foreach my $vmid (keys %$vmstatus) {
|
||||
my $d = $vmstatus->{$vmid};
|
||||
my $data;
|
||||
if ($d->{pid}) { # running
|
||||
|
||||
$qmpclient->queue_cmd($vmid, $statuscb, 'query-status');
|
||||
|
||||
}
|
||||
}
|
||||
print "start loop\n";
|
||||
$qmpclient->queue_execute();
|
||||
print "end loop\n";
|
||||
print Dumper($res);
|
||||
foreach my $vmid (keys %{$qmpclient->{errors}}) {
|
||||
my $msg = "qmp error on VM $vmid: $qmpclient->{errors}->{$vmid}";
|
||||
chomp $msg;
|
||||
warn "$msg\n";
|
||||
}
|
||||
|
||||
print "end update\n";
|
||||
}
|
||||
|
||||
for(;;) {
|
||||
PVE::Cluster::cfs_update();
|
||||
update_qemu_stats();
|
||||
sleep(3);
|
||||
}
|
||||
1;
|
||||
|
||||
@ -25,6 +25,7 @@ use PVE::Tools qw(run_command lock_file file_read_firstline);
|
||||
use PVE::Cluster qw(cfs_register_file cfs_read_file cfs_write_file cfs_lock_file);
|
||||
use PVE::INotify;
|
||||
use PVE::ProcFSTools;
|
||||
use PVE::QMPClient;
|
||||
use Time::HiRes qw(gettimeofday);
|
||||
|
||||
my $cpuinfo = PVE::ProcFSTools::read_cpuinfo();
|
||||
@ -2677,46 +2678,6 @@ sub vm_start {
|
||||
});
|
||||
}
|
||||
|
||||
my $qmp_read_avail = sub {
|
||||
my ($fh, $timeout) = @_;
|
||||
|
||||
my $sel = new IO::Select;
|
||||
$sel->add($fh);
|
||||
|
||||
my $res = '';
|
||||
my $buf;
|
||||
|
||||
my @ready;
|
||||
while (scalar (@ready = $sel->can_read($timeout))) {
|
||||
my $count;
|
||||
if ($count = $fh->sysread($buf, 8192)) {
|
||||
$res .= $buf;
|
||||
last if $buf =~ (m/}\r\n$/);
|
||||
} else {
|
||||
if (!defined($count)) {
|
||||
die "$!\n";
|
||||
}
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
die "qmp read timeout\n" if !scalar(@ready);
|
||||
|
||||
my @jsons = split("\n", $res);
|
||||
my $obj = {};
|
||||
my $event = {};
|
||||
my $return = {};
|
||||
foreach my $json (@jsons) {
|
||||
$obj = from_json($json);
|
||||
$event = $obj->{event} if exists $obj->{event};
|
||||
$return = $obj->{QMP} if exists $obj->{QMP};
|
||||
$return = $obj->{"return"} if exists $obj->{"return"};
|
||||
die $obj->{error}->{desc} if exists $obj->{error}->{desc} && $obj->{error}->{desc} !~ m/Connection can not be completed immediately/;
|
||||
}
|
||||
|
||||
return ($return,$event);
|
||||
};
|
||||
|
||||
sub __read_avail {
|
||||
my ($fh, $timeout) = @_;
|
||||
|
||||
@ -2826,96 +2787,31 @@ sub vm_monitor_command {
|
||||
sub vm_mon_cmd {
|
||||
my ($vmid, $execute, %params) = @_;
|
||||
|
||||
my $cmd = {};
|
||||
$cmd->{execute} = $execute;
|
||||
$cmd->{arguments} = \%params;
|
||||
vm_qmp_command($vmid,$cmd);
|
||||
my $cmd = { execute => $execute, arguments => \%params };
|
||||
vm_qmp_command($vmid, $cmd);
|
||||
}
|
||||
|
||||
sub vm_mon_cmd_nocheck {
|
||||
my ($vmid, $execute, %params) = @_;
|
||||
|
||||
my $cmd = {};
|
||||
$cmd->{execute} = $execute;
|
||||
$cmd->{arguments} = \%params;
|
||||
vm_qmp_command($vmid,$cmd,1);
|
||||
my $cmd = { execute => $execute, arguments => \%params };
|
||||
vm_qmp_command($vmid, $cmd, 1);
|
||||
}
|
||||
|
||||
sub vm_qmp_command {
|
||||
my ($vmid, $cmd, $nocheck) = @_;
|
||||
|
||||
#http://git.qemu.org/?p=qemu.git;a=blob;f=qmp-commands.hx;h=db980fa811325aeca8ad43472ba468702d4a25a2;hb=HEAD
|
||||
my $res;
|
||||
my $event;
|
||||
|
||||
eval {
|
||||
die "VM $vmid not running\n" if !check_running($vmid, $nocheck);
|
||||
|
||||
my $sname = qmp_socket($vmid);
|
||||
my $sock = IO::Socket::UNIX->new( Peer => $sname ) ||
|
||||
die "unable to connect to VM $vmid socket - $!\n";
|
||||
my $qmpclient = PVE::QMPClient->new();
|
||||
|
||||
my $timeout = 3;
|
||||
$res = $qmpclient->cmd($vmid, $cmd);
|
||||
|
||||
# maybe this works with qmp, need to be tested
|
||||
|
||||
# hack: migrate sometime blocks the monitor (when migrate_downtime
|
||||
# is set)
|
||||
|
||||
$timeout = 60*60 if ($cmd->{execute} =~ m/(migrate)$/);
|
||||
|
||||
|
||||
# read banner;
|
||||
my $data = &$qmp_read_avail($sock, $timeout);
|
||||
# '{"QMP": {"version": {"qemu": {"micro": 93, "minor": 0, "major": 1}, "package": " (qemu-kvm-devel)"}, "capabilities": []}} ';
|
||||
die "got unexpected qemu qmp banner\n" if !$data;
|
||||
|
||||
my $sel = new IO::Select;
|
||||
$sel->add($sock);
|
||||
|
||||
#negociation
|
||||
my $negociation = '{ "execute": "qmp_capabilities" }';
|
||||
|
||||
if (!scalar(my @ready = $sel->can_write($timeout))) {
|
||||
die "monitor write error - timeout";
|
||||
}
|
||||
|
||||
my $b;
|
||||
if (!($b = $sock->syswrite($negociation)) || ($b != length($negociation))) {
|
||||
die "monitor write error - $!";
|
||||
}
|
||||
|
||||
$res = &$qmp_read_avail($sock, $timeout);
|
||||
# res = '{"return": {}}
|
||||
die "qmp negociation error\n" if !$res;
|
||||
|
||||
$timeout = 20;
|
||||
|
||||
my $cmdjson;
|
||||
|
||||
#generate json from hash for complex cmd
|
||||
$cmdjson = to_json($cmd);
|
||||
|
||||
if ($cmd->{execute} =~ m/(migrate)$/) {
|
||||
$timeout = 60*60; # 1 hour
|
||||
} elsif ($cmd->{execute} =~ m/^(eject|change)/) {
|
||||
$timeout = 60; # note: cdrom mount command is slow
|
||||
}
|
||||
|
||||
|
||||
if (!($b = $sock->syswrite($cmdjson)) || ($b != length($cmdjson))) {
|
||||
die "monitor write error - $!";
|
||||
}
|
||||
|
||||
|
||||
return if ($cmd->{execute} eq 'q') || ($cmd->{execute} eq 'quit');
|
||||
|
||||
|
||||
($res,$event) = &$qmp_read_avail($sock, $timeout);
|
||||
};
|
||||
|
||||
my $err = $@;
|
||||
|
||||
if ($err) {
|
||||
if (my $err = $@) {
|
||||
syslog("err", "VM $vmid qmp command failed - $err");
|
||||
die $err;
|
||||
}
|
||||
|
||||
@ -1,3 +1,9 @@
|
||||
qemu-server (2.0-43) unstable; urgency=low
|
||||
|
||||
* use new QMPClient code
|
||||
|
||||
-- Proxmox Support Team <support@proxmox.com> Fri, 13 Jul 2012 07:05:28 +0200
|
||||
|
||||
qemu-server (2.0-42) unstable; urgency=low
|
||||
|
||||
* fix pool permission checks on create
|
||||
|
||||
@ -3,7 +3,7 @@ Version: @@VERSION@@-@@PKGRELEASE@@
|
||||
Section: admin
|
||||
Priority: optional
|
||||
Architecture: @@ARCH@@
|
||||
Depends: libc6 (>= 2.7-18), perl (>= 5.10.0-19), libterm-readline-gnu-perl, pve-qemu-kvm (>= 0.11.1) | pve-qemu-kvm-2.6.18, netcat-traditional, libpve-storage-perl, pve-cluster, redhat-cluster-pve, libjson-perl, libjson-xs-perl
|
||||
Depends: libc6 (>= 2.7-18), perl (>= 5.10.0-19), libterm-readline-gnu-perl, pve-qemu-kvm (>= 0.11.1) | pve-qemu-kvm-2.6.18, netcat-traditional, libpve-storage-perl, pve-cluster, redhat-cluster-pve, libjson-perl, libjson-xs-perl, libio-multiplex-perl
|
||||
Conflicts: netcat-openbsd
|
||||
Maintainer: Proxmox Support Team <support@proxmox.com>
|
||||
Description: Qemu Server Tools
|
||||
|
||||
Loading…
Reference in New Issue
Block a user