-#!/usr/bin/perl -w
-
package PVE::QMPClient;
use strict;
#use PVE::SafeSyslog;
use PVE::QemuServer;
use IO::Multiplex;
+use POSIX qw(EINTR EAGAIN);
use JSON;
+use Time::HiRes qw(usleep gettimeofday tv_interval);
+
use Data::Dumper;
# Qemu Monitor Protocol (QMP) client.
# execute a single command
sub cmd {
- my ($self, $vmid, $cmd) = @_;
+ my ($self, $vmid, $cmd, $timeout) = @_;
my $result;
$result = $resp->{'return'};
};
+ die "no command specified" if !($cmd && $cmd->{execute});
+
$cmd->{callback} = $callback;
$cmd->{arguments} = {} if !defined($cmd->{arguments});
$self->{queue}->{$vmid} = [ $cmd ];
- $self->queue_execute();
+ if (!$timeout) {
+ # hack: monitor sometime blocks
+ if ($cmd->{execute} eq 'query-migrate') {
+ $timeout = 60*60; # 1 hour
+ } elsif ($cmd->{execute} =~ m/^(eject|change)/) {
+ $timeout = 60; # note: cdrom mount command is slow
+ } elsif ($cmd->{execute} eq 'savevm-start' ||
+ $cmd->{execute} eq 'savevm-end' ||
+ $cmd->{execute} eq 'query-savevm' ||
+ $cmd->{execute} eq 'delete-drive-snapshot' ||
+ $cmd->{execute} eq 'snapshot-drive' ) {
+ $timeout = 10*60; # 10 mins ?
+ } else {
+ $timeout = 3; # default
+ }
+ }
+
+ $self->queue_execute($timeout);
my $cmdstr = $cmd->{execute} || '';
die "VM $vmid qmp command '$cmdstr' failed - $self->{errors}->{$vmid}"
delete $self->{fhs_lookup}->{$fh};
$self->{mux}->close($fh);
-
- print "CLOSE SOCKET to $vmid\n";
-
};
my $open_connection = sub {
- my ($self, $vmid) = @_;
+ my ($self, $vmid, $timeout) = @_;
my $sname = PVE::QemuServer::qmp_socket($vmid);
- my $fh = IO::Socket::UNIX->new(Peer => $sname, Blocking => 0, Timeout => 1) ||
- die "unable to connect to VM $vmid socket - $!\n";
+ $timeout = 1 if !$timeout;
- print "OPEN SOCKET to $vmid \n";
+ my $fh;
+ my $starttime = [gettimeofday];
+ my $count = 0;
+ for (;;) {
+ $count++;
+ $fh = IO::Socket::UNIX->new(Peer => $sname, Blocking => 0, Timeout => 1);
+ last if $fh;
+ if ($! != EINTR && $! != EAGAIN) {
+ die "unable to connect to VM $vmid socket - $!\n";
+ }
+ my $elapsed = tv_interval($starttime, [gettimeofday]);
+ if ($elapsed >= $timeout) {
+ die "unable to connect to VM $vmid socket - timeout after $count retries\n";
+ }
+ usleep(100000);
+ }
$self->{fhs}->{$vmid} = $fh;
$self->{fhs_lookup}->{$fh} = $vmid;
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++;
}
$timeout = 3 if !$timeout;
- print "start exec queue\n";
-
$self->{current} = {};
$self->{errors} = {};
next if !scalar(@{$self->{queue}->{$vmid}}); # no commands for the VM
eval {
- my $fh = &$open_connection($self, $vmid);
+ my $fh = &$open_connection($self, $vmid, $timeout);
my $cmd = { execute => 'qmp_capabilities', arguments => {} };
unshift @{$self->{queue}->{$vmid}}, $cmd;
$self->{mux}->set_timeout($fh, $timeout);
}
$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
sub mux_input {
my ($self, $mux, $fh, $input) = @_;
- print "GOT: $$input\n";
-
return if $$input !~ m/}\r\n$/;
my $raw = $$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);
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;
projects / qemu-server.git / blobdiff